├── .ghci ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── CONTRIBUTORS ├── LICENSE ├── README.SNAP.md ├── README.md ├── Setup.hs ├── TODO ├── docs ├── Makefile ├── templates.css └── templates.md ├── examples ├── ex01 │ ├── home.tpl │ └── nav.tpl ├── ex02 │ ├── default.tpl │ └── home.tpl ├── ex03 │ ├── default.tpl │ └── home.tpl ├── test01.tpl └── test02.tpl ├── extra ├── haddock.css ├── hscolour.css └── logo.gif ├── haddock.sh ├── heist.cabal ├── src ├── Data │ └── HeterogeneousEnvironment.hs ├── Heist.hs └── Heist │ ├── Common.hs │ ├── Compiled.hs │ ├── Compiled │ ├── Internal.hs │ └── LowLevel.hs │ ├── Internal │ ├── Types.hs │ └── Types │ │ └── HeistState.hs │ ├── Interpreted.hs │ ├── Interpreted │ └── Internal.hs │ ├── Splices.hs │ ├── Splices │ ├── Apply.hs │ ├── Bind.hs │ ├── BindStrict.hs │ ├── Cache.hs │ ├── Html.hs │ ├── Ignore.hs │ ├── Json.hs │ └── Markdown.hs │ └── TemplateDirectory.hs └── test ├── runTestsAndCoverage.sh ├── suite ├── Benchmark.hs ├── Heist │ ├── Compiled │ │ └── Tests.hs │ ├── Interpreted │ │ └── Tests.hs │ ├── TestCommon.hs │ ├── Tests.hs │ └── Tutorial │ │ ├── AttributeSplices.lhs │ │ ├── CompiledSplices.lhs │ │ └── Imports.hs └── TestSuite.hs ├── templates-bad ├── apply-missing-attr.tpl ├── apply-template-not-found.tpl ├── bind-infinite-loop.tpl └── bind-missing-attr.tpl ├── templates-defer └── test.tpl ├── templates-loaderror ├── _error.tpl ├── _ok.tpl └── test.tpl ├── templates-no-ns └── test.tpl ├── templates-ns-nested └── test.tpl ├── templates-nsbind ├── nsbind.tpl └── nsbinderror.tpl ├── templates-nscall ├── _call.tpl ├── _invalid.tpl └── nscall.tpl └── templates ├── a.tpl ├── attr_splice.tpl ├── attrs.tpl ├── attrsubtest1.tpl ├── attrsubtest2.tpl ├── backslash.tpl ├── bar ├── a.tpl └── index.tpl ├── bind-apply-interaction ├── _outer.tpl └── caller.tpl ├── bind-attrs.tpl ├── bind_param.tpl ├── cache.tpl ├── div_expansion.tpl ├── foo ├── a.tpl ├── b.tpl ├── markdown-chdir.tpl ├── markdown-origdir.tpl └── test2.md ├── head_merge ├── index.tpl ├── nav.tpl └── wrap.tpl ├── index.tpl ├── ioc.tpl ├── json.tpl ├── json_array.tpl ├── json_object.tpl ├── json_snippet.tpl ├── markdown.tpl ├── namespaces.tpl ├── page.tpl ├── pandoc.tpl ├── pandocdiv.tpl ├── people.tpl ├── post.tpl ├── readme.txt ├── rss.xtpl ├── test.md ├── textarea_expansion.tpl ├── title_expansion.tpl └── user ├── admin ├── main.tpl └── menu.tpl ├── main.tpl └── menu.tpl /.ghci: -------------------------------------------------------------------------------- 1 | :set -XOverloadedStrings 2 | :set -XCPP 3 | :set -Wall 4 | :set -isrc 5 | :set -itest/suite 6 | :set -hide-package MonadCatchIO-mtl 7 | :set -hide-package monads-tf 8 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # Modified from https://kodimensional.dev/github-actions 2 | 3 | name: CI 4 | 5 | on: 6 | pull_request: 7 | types: [synchronize, opened, reopened] 8 | paths-ignore: 9 | - "**.md" 10 | - "CODEOWNERS" 11 | - "CONTRIBUTORS" 12 | - "LICENSE" 13 | - "TODO" 14 | - "docs/**" 15 | - "extra/**" 16 | push: 17 | branches: 18 | - 'master' 19 | schedule: 20 | # Additionally run once per week (At 00:00 on Sunday) to maintain cache. 21 | - cron: '0 0 * * 0' 22 | 23 | jobs: 24 | cabal: 25 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 26 | runs-on: ${{ matrix.os }} 27 | 28 | strategy: 29 | fail-fast: false 30 | matrix: 31 | os: [ubuntu-latest] 32 | ghc: 33 | - "8.8" 34 | - "8.10" 35 | - "9.0" 36 | - "9.2" 37 | - "9.4" 38 | - "9.6" 39 | - "9.8" 40 | - "9.10" 41 | include: 42 | - { os: macOS-latest, ghc: "9.10" } 43 | - { os: windows-latest, ghc: "9.10" } 44 | 45 | steps: 46 | - uses: actions/checkout@v4 47 | 48 | - name: Set up GHC ${{ matrix.ghc-version }} 49 | uses: haskell-actions/setup@v2 50 | id: setup 51 | with: 52 | ghc-version: ${{ matrix.ghc }} 53 | 54 | - name: Configure 55 | run: | 56 | cabal configure --enable-tests --enable-benchmarks --enable-documentation 57 | cabal build --dry-run 58 | 59 | - name: Restore cached dependencies 60 | uses: actions/cache/restore@v4 61 | id: cache 62 | env: 63 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 64 | with: 65 | path: ${{ steps.setup.outputs.cabal-store }} 66 | key: ${{ env.key }}-plan-${{ hashFiles('dist-newstyle/cache/plan.json') }} 67 | restore-keys: ${{ env.key }}- 68 | 69 | - name: Install dependencies 70 | run: cabal build all --only-dependencies 71 | 72 | - name: Save cached dependencies 73 | uses: actions/cache/save@v4 74 | if: ${{ steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} 75 | with: 76 | path: ${{ steps.setup.outputs.cabal-store }} 77 | key: ${{ steps.cache.outputs.cache-primary-key }} 78 | 79 | - name: Build 80 | run: cabal build all 81 | 82 | - uses: nikeee/setup-pandoc@v1 83 | if: runner.os == 'Linux' 84 | 85 | # Work is needed to get tests to pass on other OSes. 86 | - name: Test 87 | if: runner.os == 'Linux' 88 | run: cabal test all 89 | 90 | - name: Documentation 91 | if: matrix.ghc >= '9.4' 92 | run: cabal haddock 93 | 94 | stack: 95 | name: stack / ghc ${{ matrix.ghc }} 96 | runs-on: ubuntu-latest 97 | 98 | strategy: 99 | matrix: 100 | include: 101 | # GHC version must match https://www.stackage.org/nightly 102 | - stack: "latest" 103 | ghc: "9.8" 104 | 105 | steps: 106 | - uses: nikeee/setup-pandoc@v1 107 | 108 | - uses: actions/checkout@v4 109 | 110 | - uses: haskell-actions/setup@v2 111 | name: Setup Haskell Stack 112 | id: setup 113 | with: 114 | ghc-version: ${{ matrix.ghc }} 115 | stack-version: ${{ matrix.stack }} 116 | 117 | - name: Configure 118 | run: | 119 | cat < stack.yaml 120 | packages: 121 | - '.' 122 | resolver: nightly-2023-07-17 123 | EOF 124 | stack config set system-ghc true --global 125 | stack config set resolver nightly 126 | 127 | - uses: actions/cache@v4 128 | name: Cache 129 | with: 130 | path: | 131 | ~/.stack 132 | key: ${{ runner.os }}-${{ steps.setup.outputs.ghc-version }}-stack 133 | 134 | - name: Install dependencies 135 | run: | 136 | stack build --test --bench --no-run-tests --no-run-benchmarks --only-dependencies 137 | 138 | - name: Build 139 | run: | 140 | stack build --test --bench --no-run-tests --no-run-benchmarks 141 | 142 | - name: Test 143 | run: | 144 | stack test 145 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist/ 3 | dist-newstyle/ 4 | cabal-dev/ 5 | *.tix 6 | .hpc 7 | *.prof 8 | *.hi 9 | *.o 10 | *.swp 11 | #*# 12 | .#* 13 | .DS_Store 14 | **/.DS_Store 15 | docs/out 16 | tags 17 | cabal.sandbox.config 18 | .cabal-sandbox 19 | .ghc.environment* 20 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Import cleanup 19 | - imports: 20 | # There are different ways we can align names and lists. 21 | # 22 | # - global: Align the import names and import list throughout the entire 23 | # file. 24 | # 25 | # - file: Like global, but don't add padding when there are no qualified 26 | # imports in the file. 27 | # 28 | # - group: Only align the imports per group (a group is formed by adjacent 29 | # import lines). 30 | # 31 | # - none: Do not perform any alignment. 32 | # 33 | # Default: global. 34 | align: global 35 | 36 | # Language pragmas 37 | - language_pragmas: 38 | # We can generate different styles of language pragma lists. 39 | # 40 | # - vertical: Vertical-spaced language pragmas, one per line. 41 | # 42 | # - compact: A more compact style. 43 | # 44 | # Default: vertical. 45 | style: vertical 46 | 47 | # stylish-haskell can detect redundancy of some language pragmas. If this 48 | # is set to true, it will remove those redundant pragmas. Default: true. 49 | remove_redundant: true 50 | 51 | # Align the types in record declarations 52 | # 53 | # FIXME(greg): this should be on, see comment below re: "columns" 54 | # - records: {} 55 | 56 | # Replace tabs by spaces. This is disabled by default. 57 | - tabs: 58 | # Number of spaces to use for each tab. Default: 8, as specified by the 59 | # Haskell report. 60 | spaces: 8 61 | 62 | # Remove trailing whitespace 63 | - trailing_whitespace: {} 64 | 65 | # A common setting is the number of columns (parts of) code will be wrapped 66 | # to. Different steps take this into account. Default: 80. 67 | # 68 | 69 | # NOTE(greg): this should be 80 but stylish-haskell currently has a bad bug 70 | # that causes it not to wrap long import lists. Rather than get consistently 71 | # weird output, just don't wrap the lines at all. 72 | 73 | columns: 120000 74 | 75 | # Sometimes, language extensions are specified in a cabal file or from the 76 | # command line instead of using language pragmas in the file. stylish-haskell 77 | # needs to be aware of these, so it can parse the file correctly. 78 | # 79 | # No language extensions are enabled by default. 80 | # language_extensions: 81 | # - TemplateHaskell 82 | # - QuasiQuotes 83 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.1.1.2 2 | 3 | * Support GHC 9.8 4 | * Fix broken test 5 | 6 | # 1.1.1.1 7 | 8 | * Support GHC 9.6 9 | 10 | # 1.1.1.0 11 | 12 | * Expose `lookupTemplate` and `splitTemplatePath` 13 | 14 | * Bump dependency bounds for 9.4 15 | 16 | # 1.1 17 | 18 | * Remove pandoc and pandocBS 19 | 20 | * Stop exporting readProcessWithExitCode' 21 | 22 | * Remove -S and --no-wrap arguments to pandoc for compatibility with both 1.x 23 | and 2.x versions of the pandoc command line tool 24 | 25 | * Bump map-syntax lower bound to fix 8.4 build problem 26 | 27 | # 1.0.1.3 28 | 29 | * Add Semigroup instances to support GHC 8.4 30 | 31 | # 1.0.1.0 32 | 33 | * Change benchmark from an executable section to a benchmark section in the 34 | cabal file. This eliminates the criterion dependency when doing "cabal 35 | install heist". 36 | * Export manyWith 37 | 38 | # 1.0.0.1 39 | 40 | * Drop the dependency on `errors` packages from heist testsuite and benchmark 41 | * Fix nested splice namespace warning bug (issue #85) 42 | 43 | # 1.0.0.0 44 | 45 | * Switch from MonadCatchIO-transformers to monad-control for Snap 1.0 46 | 47 | # 0.14.0 48 | 49 | See http://snapframework.com/blog/2014/09/24/heist-0.14-released 50 | 51 | * Add namespace support (hcNamespace and hcErrorNotBound) 52 | * Add tellSpliceError for generalized error reporting 53 | * Restructured HeistConfig, export lenses instead of field accessors 54 | * Moved old HeistConfig into SpliceConfig 55 | * Factored SpliceAPI module out into separate map-syntax package 56 | 57 | # 0.13.0 58 | 59 | See http://snapframework.com/blog/2013/09/09/snap-0.13-released 60 | 61 | * Simpler compiled splice API 62 | * New splice syntax 63 | 64 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Doug Beardsley 2 | Gregory Collins 3 | Carl Howells 4 | Edward Kmett 5 | Will Langstroth 6 | Shane O'Brien 7 | James Sanders 8 | Mark Wright 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | Neither the name of the Snap Framework authors nor the names of its 15 | contributors may be used to endorse or promote products derived from this 16 | software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.SNAP.md: -------------------------------------------------------------------------------- 1 | Snap Framework 2 | -------------- 3 | 4 | Snap is a simple and fast web development framework and server written in 5 | Haskell. For more information or to download the latest version, you can visit 6 | the Snap project website at http://snapframework.com/. 7 | 8 | 9 | Snap Status and Features 10 | ------------------------ 11 | 12 | The Snap core system consists of: 13 | 14 | * a high-speed HTTP server, with an optional high-concurrency backend using 15 | the [libev](http://software.schmorp.de/pkg/libev.html) library 16 | 17 | * a sensible and clean monad for web programming 18 | 19 | * an xml-based templating system for generating HTML that allows you to bind 20 | Haskell functionality to XML tags without getting PHP-style tag soup all 21 | over your pants 22 | 23 | * a "snaplet" system for building web sites from composable pieces. 24 | 25 | Snap is currently only officially supported on Unix platforms; it has been 26 | tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. 27 | 28 | 29 | Snap Philosophy 30 | --------------- 31 | 32 | Snap aims to be the *de facto* web toolkit for Haskell, on the basis of: 33 | 34 | * High performance 35 | 36 | * High design standards 37 | 38 | * Simplicity and ease of use, even for Haskell beginners 39 | 40 | * Excellent documentation 41 | 42 | * Robustness and high test coverage 43 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Heist 2 | 3 | [![GitHub CI](https://github.com/snapframework/heist/workflows/CI/badge.svg)](https://github.com/snapframework/heist/actions) 4 | 5 | Heist, part of the [Snap Framework](http://www.snapframework.com/), is a 6 | Haskell library for xml/html templating. It uses simple XML tags to bind 7 | values to your templates in a straightforward way. For example, if you were to 8 | put the following in a template: 9 | 10 | some text 11 |

12 | 13 | the resulting xhtml would be 14 | 15 |

some text

16 | 17 | Likewise, if you need to add text to an attribute, 18 | 19 | special-id 20 |
very special
21 | 22 | gives you 23 | 24 |
very special
25 | 26 | Values can also be pulled from "Splices" (see 27 | [the documentation](http://snapframework.com/docs/tutorials/heist#heist-programming) 28 | for more information.) 29 | 30 | ## Building heist 31 | 32 | The heist library is built using [Cabal](http://www.haskell.org/cabal/) and 33 | [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run 34 | 35 | cabal install 36 | 37 | from the `heist` toplevel directory. 38 | 39 | 40 | ## Building the Haddock Documentation 41 | 42 | The haddock documentation can be built using the supplied `haddock.sh` shell 43 | script: 44 | 45 | ./haddock.sh 46 | 47 | The docs get put in `dist/doc/html/`. 48 | 49 | 50 | ## Building the testsuite 51 | 52 | To build the test suite, `cd` into the `test/` directory and run 53 | 54 | $ cabal configure 55 | $ cabal build 56 | 57 | From here you can invoke the testsuite by running: 58 | 59 | $ ./runTestsAndCoverage.sh 60 | 61 | The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. 62 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Fix handling of ".." in apply tags 2 | 3 | Ongoing 4 | ------- 5 | 6 | * Improve test coverage 7 | * Head merging (ala the Lift Web Framework) 8 | 9 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | all: out/templates.html 2 | 3 | clean: 4 | rm -Rf out 5 | 6 | out/templates.html: templates.md templates.css 7 | mkdir -p out 8 | cp templates.css out/ 9 | pandoc -c templates.css -s -f markdown -o out/templates.html templates.md 10 | -------------------------------------------------------------------------------- /docs/templates.css: -------------------------------------------------------------------------------- 1 | body{ 2 | font-size: 12pt; 3 | color:#2c558a; 4 | background:#fdfeff; 5 | width: 75ex; 6 | margin:0 auto; 7 | font-family: "Helvetica Neue", "Arial", "Helvetica", sans-serif; 8 | } 9 | 10 | a:link, a:visited, a:active, a:hover{ 11 | text-decoration: none; 12 | } 13 | 14 | a:link, a:visited { 15 | color: #3d3dff; 16 | } 17 | 18 | a:hover { 19 | color: #622c8c; 20 | } 21 | 22 | a:active { 23 | color: #8c2c85; 24 | } 25 | 26 | h1,h2,h3{ 27 | font-weight:normal; 28 | color:#2c558a; 29 | letter-spacing:-0.02em; 30 | } 31 | 32 | h1{ 33 | font-size:2em; 34 | } 35 | h2{ 36 | font-size:1.5em; 37 | } 38 | h3{ 39 | font-weight: bold; 40 | } 41 | p{ 42 | line-height:1.7em; 43 | text-align: justify; 44 | } 45 | ul li{ 46 | padding: 0.5em 0em; 47 | } 48 | -------------------------------------------------------------------------------- /docs/templates.md: -------------------------------------------------------------------------------- 1 | ## Heist Templates 2 | 3 | Heist templates serve two primary design goals. First, they facilitate 4 | the separation of the view from the other aspects of your application. 5 | Second, they provide abstraction capabilities that allow you to avoid 6 | repeated template code. This allows you to follow the DRY principle 7 | (Don't Repeat Yourself) in the development of your application views. 8 | 9 | Heist has two primary template abstraction constructs: bind and apply. 10 | They are implemented as specialized XML tags. 11 | 12 | ### The `` tag 13 | 14 | The `bind` tag allows you to bind XML content to a single tag. 15 | Whenever the bound tag is used, the template engine will substitute 16 | the 'bind' tag's child nodes in its place. This allows you to 17 | essentially create your own higher-level markup language that Heist 18 | transforms into whatever XML-based markup language is native to your 19 | application. 20 | 21 | #### Attributes 22 | 23 | The `bind` tag has a single required attribute called `tag` specifying the 24 | name of the bound tag. If this attribute is not present, then the 25 | `bind` tag has no effect. 26 | 27 | #### Example 28 | 29 | Here's a simple example demonstrating the use of bind. 30 | 31 | ~~~~~~~~~~~~~~~ {.html} 32 | 33 | Einstein, Feynman, Heisenberg, and Newton Reasearch Corporation 34 | Ltd.TM 35 | 36 | We at have research expertise in many areas of physics. 37 | Employment at carries significant prestige. The rigorous 38 | hiring process developed by is leading the industry. 39 | ~~~~~~~~~~~~~~~ 40 | 41 | The full company name will be substituted at every occurrance of the 42 | `` tag. This eliminates repetition and makes it easier to 43 | make changes. 44 | 45 | ### The `` tag 46 | 47 | The `apply` tag loads one of your application templates and inserts it 48 | into the current template's XML tree. If the target template does not 49 | have any special tags, then the contents of the `apply` tag are 50 | ignored. 51 | 52 | #### Attributes 53 | 54 | The `apply` tag has one required attribute called `template`. This 55 | attribute specifies the name of the template being applied. Heist 56 | template names work a little differently from traditional paths and 57 | filenames. 58 | 59 | If the template name contains a '/' character, then it will behave 60 | like traditional relative and absolute paths. The root directory will 61 | be the root of your template directory tree, and the current directory 62 | will be the directory containing whatever template is currently being 63 | processed. Absolute template path names start at the root directory. 64 | Relative template path names start at the current directory. 65 | 66 | If the template name does not have any '/' characters, then Heist 67 | searches in the current directory for a template with that name. If 68 | it finds one, then Heist applies the template just like you would 69 | expect. The different behavior is that if the named template is 70 | not found in the current directory, Heist recursively searches up the 71 | directory hierarchy looking for the name. Heist uses the first 72 | template it finds on the way up that has that name. If no template is 73 | found, then you'll get an error. 74 | 75 | This cascading behavior allows you to put site-wide templates in the 76 | top-level directory and selectively override them in subdirectories 77 | for certain parts of your site. 78 | 79 | #### Example 80 | 81 | Let's look at a simple example to demonstrate the most basic use of 82 | the `apply` tag. Say you have a navigation menu that is used on many 83 | different pages of your site. You want to avoid duplicating the HTML 84 | code in multiple different page templates, so you might put it in a 85 | template file by itself called `nav.tpl` that looks like this: 86 | 87 | ~~~~~~~~~~~~~~~ {.html} 88 | 93 | ~~~~~~~~~~~~~~~ 94 | 95 | Then to include this nav template in your front page template, you 96 | would use the `apply` tag. Here is what a simple home page template 97 | `home.tpl` might look like: 98 | 99 | ~~~~~~~~~~~~~~~ {.html} 100 | 101 | 102 | Home Page 103 | 104 | 105 |

Home Page

106 | 107 |

Welcome to our home page

108 | 109 | 110 | ~~~~~~~~~~~~~~~ 111 | 112 | When a user requests the `/home` URL, Heist would serve `home.tpl`, 113 | and the nav template would automatically be inserted into the page. 114 | Here is what the HTML will look like after Heist processes the 115 | template: 116 | 117 | ~~~~~~~~~~~~~~~ {.html} 118 | 119 | 120 | Home Page 121 | 122 | 123 |

Home Page

124 | 129 |

Welcome to our home page

130 | 131 | 132 | ~~~~~~~~~~~~~~~ 133 | 134 | 135 | ### The `` tag 136 | 137 | Sometimes it is useful to pass information (usually in the form of XML 138 | data) into the template when it is applied so the template can insert 139 | it in useful places. This allows you to build page templates that are 140 | not just static blocks of code. If you are a programmer, you can 141 | think of a template as if it was a function that could have any number 142 | of parameters. 143 | 144 | In our previous example, we did not pass any parameters to the `nav` 145 | template when it was applied, so the `` tag was empty. If we 146 | include data inside the body of the `` tag, the template being 147 | called can access this data with the `` tag. The following 148 | simple example illustrates this concept. We create a site template 149 | called `default.tpl`: 150 | 151 | ~~~~~~~~~~~~~~~ {.html} 152 | 153 | 154 | Home Page 155 | 156 | 157 | 160 |
161 | 162 |
163 | 166 | 167 | 168 | ~~~~~~~~~~~~~~~ 169 | 170 | 171 | The `` tag "pulls in" the page content from the calling 172 | template and inserts it into the content `
`. 173 | 174 | Now we have a template for our home page called home.tpl: 175 | 176 | ~~~~~~~~~~~~~~~ {.html} 177 | 178 |

Home Page

179 |

Welcome to XYZ Inc

180 | 181 | ~~~~~~~~~~~~~~~ 182 | 183 | And when Heist receives a request to `/home`, it will serve the 184 | following: 185 | 186 | ~~~~~~~~~~~~~~~ {.html} 187 | 188 | 189 | Home Page 190 | 191 | 192 | 195 |
196 |

Home Page

197 |

Welcome to XYZ Inc

198 |
199 | 202 | 203 | 204 | ~~~~~~~~~~~~~~~ 205 | 206 | The two lines from inside the `` tag have been substituted into 207 | the content div in `default.tpl`. Notice the difference between these 208 | two examples. In the first example we pulled in a template 209 | (`nav.tpl`) that went inside the page being served (`home.tpl`). In 210 | the second example, `home.tpl` is still the intended target of 211 | requests, but the `default.tpl` template surrounds the content that 212 | home.tpl supplies as an argument. This seems like different behavior, 213 | but it is just a different use of the same `apply` tag. This 214 | illustrates the power of a simple concept like `apply`. 215 | 216 | ### Using Bind and Apply 217 | 218 | What if, in the above example, we decided that the contents of the 219 | header div should be different for different pages? To do this, we 220 | need a way to pass multiple parameters into a template. Heist 221 | provides this capability with the `` tag. Inside the body of a 222 | `` tag, you can have multiple bind tags surrounding data to be 223 | passed as separate parameters. Each `` tag must have a `tag` 224 | attribute that provides a name for its contents just as described 225 | above. Then, inside the template, those tags will be substituted with 226 | the appropriate data. 227 | 228 | The previous example only needs a few modifications to `default.tpl` 229 | to allow multiple parameters. 230 | 231 | ~~~~~~~~~~~~~~~ {.html} 232 | 233 | 234 | Home Page 235 | 236 | 237 | 240 |
241 |
242 |
243 | 246 | 247 | 248 | ~~~~~~~~~~~~~~~ 249 | 250 | 251 | And `home.tpl` uses the `` tag with a name attribute to define 252 | values for the `
` and `
` tags: 253 | 254 | ~~~~~~~~~~~~~~~ {.html} 255 | 256 | 257 |

XYZ Inc.

258 | 259 | Some in-between text. 260 | 261 |

Home Page

262 |

Welcome to XYZ Inc

263 | 264 | 265 | ~~~~~~~~~~~~~~~ 266 | 267 | The result template for this example is the same as the previous 268 | example. 269 | 270 | NOTE: In this example the `` tag is still bound as described 271 | above. The `` tag is always bound to the complete contents 272 | of the calling `apply` tag. However, any `bind` tags inside the apply 273 | will disappear. If we changed `default.tpl` to the following: 274 | 275 | ~~~~~~~~~~~~~~~ {.html} 276 | 277 | 278 | 279 | ~~~~~~~~~~~~~~~ 280 | 281 | Then the above `home.tpl` template would render like this: 282 | 283 | ~~~~~~~~~~~~~~~ {.html} 284 | 285 | Some in-between text. 286 | 287 | ~~~~~~~~~~~~~~~ 288 | 289 | 290 | ### The `` tag 291 | 292 | In some cases you may want to include example data in a Heist template 293 | that should not be rendered when the site is active. Heist provides 294 | the `` tag for this purpose. All `` tags and their 295 | contents will be eliminated in a template's output. 296 | 297 | 298 | ### The `` tag 299 | 300 | XML requires that well-formed documents have a single root element. 301 | Sometimes you might want to make templates that don't have a single 302 | root element. In these situations the `` tag is just what 303 | you want. When the children tag is rendered, it strips itself off and 304 | just returns its child nodes. This allows you to have a single root 305 | element where necessary, but have that tag disappear in the rendered 306 | output. 307 | 308 | 309 | -------------------------------------------------------------------------------- /examples/ex01/home.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | Home Page 4 | 5 | 6 |

Home Page

7 | 8 |

Welcome to our home page.

9 | 10 | 11 | -------------------------------------------------------------------------------- /examples/ex01/nav.tpl: -------------------------------------------------------------------------------- 1 | 6 | -------------------------------------------------------------------------------- /examples/ex02/default.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | Home Page 4 | 5 | 6 | 9 |
10 | 11 |
12 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /examples/ex02/home.tpl: -------------------------------------------------------------------------------- 1 | 2 |

Home Page

3 |

Welcome to XYZ Inc

4 | 5 | -------------------------------------------------------------------------------- /examples/ex03/default.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | Home Page 4 | 5 | 6 | 9 |
10 |
11 |
12 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /examples/ex03/home.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |

XYZ Inc.

4 | 5 | 6 |

Home Page

7 |

Welcome to XYZ Inc

8 | 9 | 10 | -------------------------------------------------------------------------------- /examples/test01.tpl: -------------------------------------------------------------------------------- 1 | bar 2 | -------------------------------------------------------------------------------- /examples/test02.tpl: -------------------------------------------------------------------------------- 1 | *** 2 | 3 | This is a test of the emergency broadcasting system. 4 | 5 | 6 | -------------------------------------------------------------------------------- /extra/haddock.css: -------------------------------------------------------------------------------- 1 | /* -------- Global things --------- */ 2 | 3 | HTML { 4 | background-color: #f0f3ff; 5 | width: 100%; 6 | } 7 | 8 | BODY { 9 | -moz-border-radius:5px; 10 | -webkit-border-radius:5px; 11 | width: 50em; 12 | margin: 2em auto; 13 | padding: 0; 14 | background-color: #ffffff; 15 | color: #000000; 16 | font-size: 110%; 17 | font-family: Georgia, serif; 18 | } 19 | 20 | A:link { color: #5200A3; text-decoration: none } 21 | A:visited { color: #5200A3; text-decoration: none } 22 | A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; } 23 | 24 | TABLE.vanilla { 25 | width: 100%; 26 | border-width: 0px; 27 | /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ 28 | } 29 | 30 | DL { 31 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 32 | letter-spacing: -0.01em; 33 | margin: 0; 34 | } 35 | 36 | .vanilla .vanilla dl { font-size: 80%; } 37 | .vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; } 38 | 39 | TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL { 40 | padding: 0 30px 0 34px; 41 | } 42 | 43 | TABLE.vanilla2 { 44 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 45 | border-width: 0px; 46 | } 47 | 48 | /* font is a little too small in MSIE */ 49 | TT, PRE, CODE { 50 | font-family: Monaco, 51 | "DejaVu Sans Mono", 52 | "Bitstream Vera Sans Mono", 53 | "Lucida Console", 54 | monospace; 55 | font-size: 90%; 56 | } 57 | 58 | LI P { margin: 0pt } 59 | 60 | P { margin-top: 0; margin-bottom: 0.75em; } 61 | 62 | TD { 63 | border-width: 0px; 64 | } 65 | 66 | TABLE.narrow { 67 | border-width: 0px; 68 | } 69 | 70 | TD.s8 { height: 0; margin:0; padding: 0 } 71 | TD.s15 { height: 20px; } 72 | 73 | SPAN.keyword { text-decoration: underline; } 74 | 75 | /* Resize the buttom image to match the text size */ 76 | IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } 77 | 78 | /* --------- Contents page ---------- */ 79 | 80 | DIV.node { 81 | padding-left: 3em; 82 | } 83 | 84 | DIV.cnode { 85 | padding-left: 1.75em; 86 | } 87 | 88 | SPAN.pkg { 89 | position: absolute; 90 | left: 50em; 91 | } 92 | 93 | /* --------- Documentation elements ---------- */ 94 | 95 | TD FONT { font-weight: bold; letter-spacing: -0.02em; } 96 | 97 | TD.children { 98 | padding-left: 25px; 99 | } 100 | 101 | TD.synopsis { 102 | padding: 2px; 103 | background-color: #f0f0f0; 104 | font-size: 80%; 105 | font-family: Monaco, 106 | "DejaVu Sans Mono", 107 | "Bitstream Vera Sans Mono", 108 | "Lucida Console", 109 | monospace; 110 | 111 | } 112 | 113 | TD.decl { 114 | padding: 4px 8px; 115 | background-color: #FAFAFA; 116 | border-bottom: #F2F2F2 solid 1px; 117 | border-top: #FCFCFC solid 1px; 118 | font-size: 80%; 119 | font-family: Monaco, 120 | "DejaVu Sans Mono", 121 | "Bitstream Vera Sans Mono", 122 | "Lucida Console", 123 | monospace; 124 | 125 | vertical-align: top; 126 | } 127 | 128 | TD.decl TD.decl { 129 | font-size: 100%; 130 | padding: 4px 0; 131 | border: 0; 132 | } 133 | 134 | TD.topdecl { 135 | padding: 20px 30px 0.5ex 30px; 136 | font-size: 80%; 137 | font-family: Monaco, 138 | "DejaVu Sans Mono", 139 | "Bitstream Vera Sans Mono", 140 | "Lucida Console", 141 | monospace; 142 | ; 143 | vertical-align: top; 144 | } 145 | 146 | .vanilla .vanilla .vanilla .topdecl { 147 | padding-left: 0; 148 | padding-right: 0; 149 | } 150 | 151 | .vanilla .vanilla .vanilla { 152 | padding-left: 30px; 153 | } 154 | 155 | .decl .vanilla { 156 | padding-left: 0px !important; 157 | } 158 | 159 | .body .vanilla .body { 160 | padding-left: 0; 161 | padding-right: 0; 162 | } 163 | 164 | .body .vanilla .body .decl { 165 | padding-left: 12px; 166 | } 167 | 168 | .body .vanilla .body div .vanilla .decl { 169 | padding-left: 12px; 170 | } 171 | 172 | TABLE.declbar { 173 | background-color: #f0f0f0; 174 | border-spacing: 0px; 175 | border-bottom:1px solid #d7d7df; 176 | border-right:1px solid #d7d7df; 177 | border-top:1px solid #f4f4f9; 178 | border-left:1px solid #f4f4f9; 179 | padding: 4px; 180 | } 181 | 182 | TD.declname { 183 | width: 100%; 184 | padding-right: 4px; 185 | } 186 | 187 | TD.declbut { 188 | padding-left: 8px; 189 | padding-right: 5px; 190 | border-left-width: 1px; 191 | border-left-color: #000099; 192 | border-left-style: solid; 193 | white-space: nowrap; 194 | font-size: x-small; 195 | } 196 | 197 | /* 198 | arg is just like decl, except that wrapping is not allowed. It is 199 | used for function and constructor arguments which have a text box 200 | to the right, where if wrapping is allowed the text box squashes up 201 | the declaration by wrapping it. 202 | */ 203 | TD.arg { 204 | padding: 2px 12px; 205 | background-color: #f0f0f0; 206 | font-size: 80%; 207 | font-family: Monaco, 208 | "DejaVu Sans Mono", 209 | "Bitstream Vera Sans Mono", 210 | "Lucida Console", 211 | monospace; 212 | 213 | vertical-align: top; 214 | white-space: nowrap; 215 | } 216 | 217 | TD.recfield { padding-left: 20px } 218 | 219 | TD.doc { 220 | padding-left: 38px; 221 | font-size: 95%; 222 | line-height: 1.66; 223 | } 224 | 225 | TD.ndoc { 226 | font-size: 95%; 227 | line-height: 1.66; 228 | padding: 2px 4px 2px 8px; 229 | } 230 | 231 | TD.rdoc { 232 | padding: 2px; 233 | padding-left: 30px; 234 | width: 100%; 235 | font-size: 80%; 236 | font-style: italic; 237 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 238 | } 239 | 240 | TD.body { 241 | padding: 0 30px; 242 | } 243 | 244 | TD.pkg { 245 | width: 100%; 246 | padding-left: 30px 247 | } 248 | 249 | TABLE.indexsearch TR.indexrow { 250 | display: none; 251 | } 252 | TABLE.indexsearch TR.indexshow { 253 | display: table-row; 254 | } 255 | 256 | TD.indexentry { 257 | vertical-align: top; 258 | padding: 0 30px 259 | } 260 | 261 | TD.indexannot { 262 | vertical-align: top; 263 | padding-left: 20px; 264 | white-space: nowrap 265 | } 266 | 267 | TD.indexlinks { 268 | width: 100% 269 | } 270 | 271 | /* ------- Section Headings ------- */ 272 | 273 | TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 { 274 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 275 | } 276 | 277 | TD.section1 { 278 | padding-top: 14px; 279 | font-weight: bold; 280 | letter-spacing: -0.02em; 281 | font-size: 140% 282 | } 283 | 284 | TD.section2 { 285 | padding-top: 4px; 286 | font-weight: bold; 287 | letter-spacing: -0.02em; 288 | font-size: 120% 289 | } 290 | 291 | TD.section3 { 292 | padding-top: 5px; 293 | font-weight: bold; 294 | letter-spacing: -0.02em; 295 | font-size: 105% 296 | } 297 | 298 | TD.section4 { 299 | font-weight: bold; 300 | padding-top: 12px; 301 | padding-bottom: 4px; 302 | letter-spacing: -0.02em; 303 | font-size: 90% 304 | } 305 | 306 | /* -------------- The title bar at the top of the page */ 307 | 308 | TD.infohead { 309 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 310 | color: #ffffff; 311 | font-weight: bold; 312 | padding: 0 30px; 313 | text-align: left; 314 | } 315 | 316 | TD.infoval { 317 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 318 | color: #ffffff; 319 | padding: 0 30px; 320 | text-align: left; 321 | } 322 | 323 | TD.topbar { 324 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 325 | background-color: #3465a4; 326 | padding: 5px; 327 | -moz-border-radius-topleft:5px; 328 | -moz-border-radius-topright:5px; 329 | -webkit-border-radius-topleft:5px; 330 | -webkit-border-radius-topright:5px; 331 | } 332 | 333 | TD.title { 334 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 335 | color: #ffffff; 336 | padding-left: 30px; 337 | letter-spacing: -0.02em; 338 | font-weight: bold; 339 | width: 100% 340 | } 341 | 342 | TD.topbut { 343 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 344 | padding-left: 5px; 345 | padding-right: 5px; 346 | border-left-width: 1px; 347 | border-left-color: #ffffff; 348 | border-left-style: solid; 349 | letter-spacing: -0.02em; 350 | font-weight: bold; 351 | white-space: nowrap; 352 | } 353 | 354 | TD.topbut A:link { 355 | color: #ffffff 356 | } 357 | 358 | TD.topbut A:visited { 359 | color: #ffff00 360 | } 361 | 362 | TD.topbut A:hover { 363 | background-color: #C9D3DE; 364 | } 365 | 366 | TD.topbut:hover { 367 | background-color: #C9D3DE; 368 | } 369 | 370 | TD.modulebar { 371 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 372 | color: #141B24; 373 | background-color: #C9D3DE; 374 | padding: 5px; 375 | border-top-width: 1px; 376 | border-top-color: #ffffff; 377 | border-top-style: solid; 378 | -moz-border-radius-bottomleft:5px; 379 | -moz-border-radius-bottomright:5px; 380 | -webkit-border-radius-bottomleft:5px; 381 | -webkit-border-radius-bottomright:5px; 382 | 383 | } 384 | 385 | /* --------- The page footer --------- */ 386 | 387 | TD.botbar { 388 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 389 | -moz-border-radius:5px; 390 | -webkit-border-radius:5px; 391 | background-color: #3465a4; 392 | color: #ffffff; 393 | padding: 5px 394 | } 395 | TD.botbar A:link { 396 | color: #ffffff; 397 | text-decoration: underline 398 | } 399 | TD.botbar A:visited { 400 | color: #ffff00 401 | } 402 | TD.botbar A:hover { 403 | background-color: #6060ff 404 | } 405 | 406 | /* --------- Mini Synopsis for Frame View --------- */ 407 | 408 | .outer { 409 | margin: 0 0; 410 | padding: 0 0; 411 | } 412 | 413 | .mini-synopsis { 414 | padding: 0.25em 0.25em; 415 | } 416 | 417 | .mini-synopsis H1 { font-size: 120%; } 418 | .mini-synopsis H2 { font-size: 107%; } 419 | .mini-synopsis H3 { font-size: 100%; } 420 | .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { 421 | font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; 422 | margin-top: 0.5em; 423 | margin-bottom: 0.25em; 424 | padding: 0 0; 425 | font-weight: bold; letter-spacing: -0.02em; 426 | } 427 | 428 | .mini-synopsis H1 { border-bottom: 1px solid #ccc; } 429 | 430 | .mini-topbar { 431 | font-size: 120%; 432 | background: #0077dd; 433 | padding: 0.25em; 434 | } 435 | 436 | 437 | -------------------------------------------------------------------------------- /extra/hscolour.css: -------------------------------------------------------------------------------- 1 | body { font-size: 90%; } 2 | 3 | pre, code, body { 4 | font-family: Monaco, 5 | "DejaVu Sans Mono", 6 | "Bitstream Vera Sans Mono", 7 | "Lucida Console", 8 | monospace; 9 | } 10 | 11 | .hs-keyglyph, .hs-layout {color: #5200A3;} 12 | .hs-keyword {color: #3465a4; font-weight: bold;} 13 | .hs-comment, .hs-comment a {color: #579; } 14 | .hs-str, .hs-chr {color: #141B24;} 15 | .hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} 16 | -------------------------------------------------------------------------------- /extra/logo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snapframework/heist/c83c54b680b7b3bb87df2283ecb80aacde1be82e/extra/logo.gif -------------------------------------------------------------------------------- /haddock.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -x 4 | 5 | HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css' 6 | 7 | cabal haddock $HADDOCK_OPTS --hyperlink-source $@ 8 | 9 | cp extra/logo.gif dist/doc/html/heist/haskell_icon.gif 10 | cp extra/hscolour.css dist/doc/html/heist/src/ 11 | -------------------------------------------------------------------------------- /heist.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: heist 3 | version: 1.1.1.2 4 | synopsis: An Haskell template system supporting both HTML5 and XML. 5 | description: 6 | Heist is a powerful template system that supports both HTML5 and XML. 7 | Some of Heist's features are: 8 | . 9 | * Designer-friendly HTML5 (or XML) syntax 10 | . 11 | * Templates can be reloaded to make changes visible without recompiling 12 | your Haskell code 13 | . 14 | * Enforces near-perfect separation of business logic and view 15 | . 16 | * Powerful abstraction primitives allowing you to eliminate repetition 17 | . 18 | * Easy creation of domain-specific markup languages 19 | . 20 | * Built-in support for including JSON and Markdown content in templates 21 | . 22 | * Simple mechanism for designer-specified template caching 23 | . 24 | * Optional merging of multiple \ tags defined anywhere in the 25 | document 26 | license: BSD-3-Clause 27 | license-file: LICENSE 28 | author: Doug Beardsley, Gregory Collins 29 | maintainer: snap@snapframework.com 30 | build-type: Simple 31 | homepage: http://snapframework.com/ 32 | category: Web, Snap 33 | 34 | tested-with: 35 | GHC == 8.8.4 36 | GHC == 8.10.7 37 | GHC == 9.0.2 38 | GHC == 9.2.8 39 | GHC == 9.4.8 40 | GHC == 9.6.5 41 | GHC == 9.8.2 42 | GHC == 9.10.1 43 | 44 | extra-doc-files: 45 | CHANGELOG.md 46 | 47 | extra-source-files: 48 | .ghci, 49 | CONTRIBUTORS, 50 | docs/Makefile, 51 | docs/templates.css, 52 | docs/templates.md, 53 | examples/ex01/home.tpl, 54 | examples/ex01/nav.tpl, 55 | examples/ex02/default.tpl, 56 | examples/ex02/home.tpl, 57 | examples/ex03/default.tpl, 58 | examples/ex03/home.tpl, 59 | examples/test01.tpl, 60 | examples/test02.tpl, 61 | extra/haddock.css, 62 | extra/hscolour.css, 63 | extra/logo.gif, 64 | haddock.sh, 65 | LICENSE, 66 | README.md, 67 | README.SNAP.md, 68 | test/suite/Benchmark.hs, 69 | test/suite/Heist/Compiled/Tests.hs, 70 | test/suite/Heist/Interpreted/Tests.hs, 71 | test/suite/Heist/TestCommon.hs, 72 | test/suite/Heist/Tests.hs, 73 | test/suite/Heist/Tutorial/AttributeSplices.lhs, 74 | test/suite/Heist/Tutorial/CompiledSplices.lhs, 75 | test/suite/Heist/Tutorial/Imports.hs, 76 | test/suite/TestSuite.hs, 77 | test/templates/a.tpl, 78 | test/templates/attr_splice.tpl, 79 | test/templates/attrs.tpl, 80 | test/templates/attrsubtest1.tpl, 81 | test/templates/attrsubtest2.tpl, 82 | test/templates/backslash.tpl 83 | test/templates/bar/a.tpl, 84 | test/templates/bar/index.tpl, 85 | test/templates/bind-apply-interaction/_outer.tpl, 86 | test/templates/bind-apply-interaction/caller.tpl, 87 | test/templates/bind-attrs.tpl, 88 | test/templates/bind_param.tpl, 89 | test/templates/cache.tpl, 90 | test/templates/div_expansion.tpl, 91 | test/templates/foo/a.tpl, 92 | test/templates/foo/b.tpl, 93 | test/templates/foo/markdown-chdir.tpl, 94 | test/templates/foo/markdown-origdir.tpl, 95 | test/templates/foo/test2.md, 96 | test/templates/head_merge/index.tpl, 97 | test/templates/head_merge/nav.tpl, 98 | test/templates/head_merge/wrap.tpl, 99 | test/templates/index.tpl, 100 | test/templates/ioc.tpl, 101 | test/templates/json.tpl, 102 | test/templates/json_array.tpl 103 | test/templates/json_object.tpl, 104 | test/templates/json_snippet.tpl, 105 | test/templates/markdown.tpl, 106 | test/templates/namespaces.tpl 107 | test/templates/page.tpl, 108 | test/templates/pandoc.tpl 109 | test/templates/pandocdiv.tpl 110 | test/templates/people.tpl, 111 | test/templates/post.tpl, 112 | test/templates/readme.txt, 113 | test/templates/rss.xtpl 114 | test/templates/test.md, 115 | test/templates/textarea_expansion.tpl, 116 | test/templates/title_expansion.tpl, 117 | test/templates/user/admin/main.tpl, 118 | test/templates/user/admin/menu.tpl, 119 | test/templates/user/main.tpl, 120 | test/templates/user/menu.tpl, 121 | test/templates-bad/apply-missing-attr.tpl, 122 | test/templates-bad/apply-template-not-found.tpl, 123 | test/templates-bad/bind-infinite-loop.tpl, 124 | test/templates-bad/bind-missing-attr.tpl, 125 | test/templates-defer/test.tpl, 126 | test/templates-loaderror/_error.tpl, 127 | test/templates-loaderror/_ok.tpl, 128 | test/templates-loaderror/test.tpl, 129 | test/templates-nsbind/nsbind.tpl, 130 | test/templates-nsbind/nsbinderror.tpl, 131 | test/templates-ns-nested/test.tpl, 132 | test/templates-nscall/_call.tpl, 133 | test/templates-nscall/_invalid.tpl, 134 | test/templates-nscall/nscall.tpl, 135 | TODO 136 | 137 | common universal 138 | default-language: Haskell2010 139 | 140 | default-extensions: 141 | DeriveDataTypeable 142 | FlexibleInstances 143 | GeneralizedNewtypeDeriving 144 | MultiParamTypeClasses 145 | OverloadedStrings 146 | PackageImports 147 | ScopedTypeVariables 148 | TypeSynonymInstances 149 | 150 | build-depends: 151 | , base >= 4.5 && < 5 152 | 153 | if !impl(ghc >= 8.0) 154 | build-depends: 155 | semigroups >= 0.16 && < 0.19, 156 | 157 | Library 158 | import: universal 159 | hs-source-dirs: src 160 | 161 | exposed-modules: 162 | Heist, 163 | Heist.Compiled, 164 | Heist.Compiled.LowLevel, 165 | Heist.Internal.Types, 166 | Heist.Interpreted, 167 | Heist.Splices, 168 | Heist.Splices.Apply, 169 | Heist.Splices.Bind, 170 | Heist.Splices.BindStrict, 171 | Heist.Splices.Cache, 172 | Heist.Splices.Html, 173 | Heist.Splices.Ignore, 174 | Heist.Splices.Json, 175 | Heist.Splices.Markdown, 176 | Heist.TemplateDirectory 177 | 178 | other-modules: 179 | Data.HeterogeneousEnvironment, 180 | Heist.Common, 181 | Heist.Compiled.Internal, 182 | Heist.Internal.Types.HeistState, 183 | Heist.Interpreted.Internal 184 | 185 | build-depends: 186 | aeson >= 0.6 && < 2.3, 187 | attoparsec >= 0.10 && < 0.15, 188 | blaze-builder >= 0.2 && < 0.5, 189 | blaze-html >= 0.4 && < 0.10, 190 | bytestring >= 0.9 && < 0.13, 191 | containers >= 0.2 && < 1.0, 192 | directory >= 1.1 && < 1.4, 193 | directory-tree >= 0.10 && < 0.13, 194 | dlist >= 0.5 && < 1.1, 195 | filepath >= 1.3 && < 2, 196 | hashable >= 1.1 && < 2, 197 | lifted-base >= 0.2 && < 0.3, 198 | map-syntax >= 0.3 && < 0.4, 199 | monad-control >= 0.3 && < 1.1, 200 | mtl >= 2.0 && < 2.4, 201 | process >= 1.1 && < 1.7, 202 | random >= 1.0.1.0 && < 1.3, 203 | text >= 0.10 && < 2.2, 204 | time >= 1.1 && < 2, 205 | transformers >= 0.3 && < 0.7, 206 | transformers-base >= 0.4 && < 0.5, 207 | unordered-containers >= 0.1.4 && < 0.3, 208 | vector >= 0.9 && < 0.14, 209 | xmlhtml >= 0.2.3.5 && < 0.4, 210 | indexed-traversable >= 0.1.1 && < 0.2 211 | 212 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 213 | 214 | default-extensions: 215 | UndecidableInstances, 216 | NoMonomorphismRestriction 217 | 218 | 219 | source-repository head 220 | type: git 221 | location: https://github.com/snapframework/heist.git 222 | 223 | Test-suite testsuite 224 | import: universal 225 | hs-source-dirs: src test/suite 226 | type: exitcode-stdio-1.0 227 | main-is: TestSuite.hs 228 | 229 | build-depends: 230 | HUnit >= 1.2 && < 2, 231 | QuickCheck >= 2 && < 2.16, 232 | lens >= 4.3 && < 5.4, 233 | test-framework >= 0.4 && < 0.9, 234 | test-framework-hunit >= 0.2.7 && < 0.4, 235 | test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, 236 | aeson, 237 | attoparsec, 238 | bifunctors >= 5.3 && < 5.7, 239 | blaze-builder, 240 | blaze-html, 241 | bytestring, 242 | containers, 243 | directory, 244 | directory-tree, 245 | dlist, 246 | filepath, 247 | hashable, 248 | lifted-base, 249 | map-syntax, 250 | monad-control, 251 | mtl, 252 | process, 253 | random, 254 | text, 255 | time, 256 | transformers, 257 | transformers-base, 258 | unordered-containers, 259 | vector, 260 | xmlhtml, 261 | indexed-traversable 262 | 263 | if impl(ghc >= 7.8) && impl(ghc < 7.10) 264 | build-depends: transformers-compat >= 0.3 && < 0.7 265 | 266 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded 267 | 268 | Benchmark benchmark 269 | import: universal 270 | hs-source-dirs: src test/suite 271 | type: exitcode-stdio-1.0 272 | main-is: Benchmark.hs 273 | 274 | build-depends: 275 | HUnit, 276 | criterion >= 1.0, 277 | criterion-measurement >= 0.1, 278 | test-framework, 279 | test-framework-hunit, 280 | 281 | -- Copied from regular dependencies: 282 | 283 | aeson, 284 | attoparsec, 285 | blaze-builder, 286 | blaze-html, 287 | bytestring, 288 | containers, 289 | directory, 290 | directory-tree, 291 | dlist, 292 | filepath, 293 | hashable, 294 | lifted-base, 295 | map-syntax, 296 | monad-control, 297 | mtl, 298 | process, 299 | random, 300 | statistics >= 0.11, 301 | text, 302 | time, 303 | transformers, 304 | transformers-base, 305 | unordered-containers, 306 | vector, 307 | xmlhtml, 308 | indexed-traversable 309 | 310 | if impl(ghc >= 7.8) && impl(ghc < 7.10) 311 | build-depends: transformers-compat 312 | 313 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded 314 | -fno-warn-unused-do-bind -rtsopts 315 | 316 | default-extensions: 317 | UndecidableInstances, 318 | NoMonomorphismRestriction 319 | -------------------------------------------------------------------------------- /src/Data/HeterogeneousEnvironment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | ------------------------------------------------------------------------------ 5 | module Data.HeterogeneousEnvironment 6 | ( KeyGen 7 | , HeterogeneousEnvironment 8 | , Key 9 | , newKeyGen 10 | , empty 11 | , makeKey 12 | , lookup 13 | , insert 14 | , delete 15 | , adjust 16 | , getKeyId 17 | ) where 18 | 19 | ------------------------------------------------------------------------------ 20 | import Control.Monad 21 | import Data.IntMap (IntMap) 22 | import qualified Data.IntMap as IM 23 | import Data.IORef 24 | import GHC.Exts 25 | import Prelude hiding (lookup) 26 | import Unsafe.Coerce 27 | 28 | ------------------------------------------------------------------------------ 29 | data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any) 30 | newtype Key a = Key Int 31 | newtype KeyGen = KeyGen (IORef Int) 32 | 33 | 34 | ------------------------------------------------------------------------------ 35 | -- | If you use two different KeyGens to work with the same map, you deserve 36 | -- what you get. 37 | newKeyGen :: IO KeyGen 38 | newKeyGen = liftM KeyGen $ newIORef 0 39 | 40 | 41 | ------------------------------------------------------------------------------ 42 | getKeyId :: Key a -> Int 43 | getKeyId (Key x) = x 44 | 45 | 46 | ------------------------------------------------------------------------------ 47 | empty :: HeterogeneousEnvironment 48 | empty = HeterogeneousEnvironment $ IM.empty 49 | 50 | 51 | ------------------------------------------------------------------------------ 52 | makeKey :: KeyGen -> IO (Key a) 53 | makeKey (KeyGen gen) = do 54 | k <- atomicModifyIORef gen nextKey 55 | return $ Key k 56 | where 57 | nextKey !x = if x >= maxBound-1 58 | then error "too many keys generated" 59 | else let !x' = x+1 in (x',x) 60 | 61 | 62 | ------------------------------------------------------------------------------ 63 | lookup :: Key a -> HeterogeneousEnvironment -> Maybe a 64 | lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m 65 | 66 | 67 | ------------------------------------------------------------------------------ 68 | insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment 69 | insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ 70 | IM.insert k (unsafeCoerce v) m 71 | 72 | 73 | ------------------------------------------------------------------------------ 74 | delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment 75 | delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ 76 | IM.delete k m 77 | 78 | 79 | ------------------------------------------------------------------------------ 80 | adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment 81 | adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ 82 | IM.adjust f' k m 83 | where 84 | f' = unsafeCoerce . f . unsafeCoerce 85 | -------------------------------------------------------------------------------- /src/Heist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | {-| 7 | 8 | This module defines the core data types used by Heist. In practice you will 9 | also want to import one or both of "Heist.Compiled" or "Heist.Interpreted" to 10 | get functions needed for writing splices. 11 | 12 | The Heist template system allows you to build custom HTML and XML based markup 13 | languages. With Heist you can define your own domain-specific tags 14 | implemented with Haskell and use them in your templates. 15 | 16 | -} 17 | 18 | module Heist 19 | ( 20 | -- * Primary Heist initialization functions 21 | loadTemplates 22 | , reloadTemplates 23 | , addTemplatePathPrefix 24 | , initHeist 25 | , initHeistWithCacheTag 26 | , defaultInterpretedSplices 27 | , defaultLoadTimeSplices 28 | , emptyHeistConfig 29 | 30 | -- * Core Heist data types 31 | , SpliceConfig 32 | , HeistConfig 33 | , TemplateRepo 34 | , TemplateLocation 35 | , Template 36 | , TPath 37 | , MIMEType 38 | , DocumentFile(..) 39 | , AttrSplice 40 | , RuntimeSplice 41 | , Chunk 42 | , HeistState 43 | , SpliceError(..) 44 | , CompileException(..) 45 | , HeistT 46 | 47 | -- * Lenses (can be used with lens or lens-family) 48 | , scInterpretedSplices 49 | , scLoadTimeSplices 50 | , scCompiledSplices 51 | , scAttributeSplices 52 | , scTemplateLocations 53 | , scCompiledTemplateFilter 54 | , hcSpliceConfig 55 | , hcNamespace 56 | , hcErrorNotBound 57 | , hcInterpretedSplices 58 | , hcLoadTimeSplices 59 | , hcCompiledSplices 60 | , hcAttributeSplices 61 | , hcTemplateLocations 62 | , hcCompiledTemplateFilter 63 | 64 | -- * HeistT functions 65 | , templateNames 66 | , compiledTemplateNames 67 | , hasTemplate 68 | , spliceNames 69 | , compiledSpliceNames 70 | , evalHeistT 71 | , getParamNode 72 | , getContext 73 | , getTemplateFilePath 74 | , localParamNode 75 | , getsHS 76 | , getHS 77 | , putHS 78 | , modifyHS 79 | , restoreHS 80 | , localHS 81 | , getDoc 82 | , getXMLDoc 83 | , tellSpliceError 84 | , spliceErrorText 85 | , orError 86 | , Splices 87 | 88 | -- * TPath functions 89 | , lookupTemplate 90 | , splitTemplatePath 91 | ) where 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | import Control.Exception.Lifted 96 | import Control.Monad.State 97 | import Data.ByteString (ByteString) 98 | import qualified Data.ByteString.Char8 as BC 99 | import qualified Data.ByteString as B 100 | import Data.Either 101 | import qualified Data.Foldable as F 102 | import Data.HashMap.Strict (HashMap) 103 | import qualified Data.HashMap.Strict as Map 104 | import qualified Data.HeterogeneousEnvironment as HE 105 | import Data.Map.Syntax 106 | #if !MIN_VERSION_base(4,11,0) 107 | import Data.Monoid 108 | #endif 109 | import Data.Text (Text) 110 | import qualified Data.Text as T 111 | import System.Directory.Tree 112 | import qualified Text.XmlHtml as X 113 | ------------------------------------------------------------------------------ 114 | import Heist.Common 115 | import qualified Heist.Compiled.Internal as C 116 | import qualified Heist.Interpreted.Internal as I 117 | import Heist.Splices 118 | import Heist.Internal.Types 119 | ------------------------------------------------------------------------------ 120 | 121 | 122 | ------------------------------------------------------------------------------ 123 | -- | The built-in set of splices that you should use in compiled splice mode. 124 | -- This list includes everything from 'defaultInterpretedSplices' plus a 125 | -- splice for the content tag that errors out when it sees any instance of the 126 | -- old content tag, which has now been moved to two separate tags called 127 | -- apply-content and bind-content. 128 | defaultLoadTimeSplices :: MonadIO m => Splices (I.Splice m) 129 | defaultLoadTimeSplices = do 130 | -- To be removed in later versions 131 | defaultInterpretedSplices 132 | "content" #! deprecatedContentCheck 133 | 134 | 135 | 136 | ------------------------------------------------------------------------------ 137 | -- | The built-in set of static splices. All the splices that used to be 138 | -- enabled by default are included here. To get the normal Heist behavior you 139 | -- should include these in the scLoadTimeSplices list in your SpliceConfig. 140 | -- If you are using interpreted splice mode, then you might also want to bind 141 | -- the 'deprecatedContentCheck' splice to the content tag as a load time 142 | -- splice. 143 | defaultInterpretedSplices :: MonadIO m => Splices (I.Splice m) 144 | defaultInterpretedSplices = do 145 | applyTag ## applyImpl 146 | bindTag ## bindImpl 147 | ignoreTag ## ignoreImpl 148 | markdownTag ## markdownSplice 149 | 150 | 151 | 152 | ------------------------------------------------------------------------------ 153 | -- | An empty HeistConfig that uses the \"h\" namespace with error checking 154 | -- turned on. 155 | emptyHeistConfig :: HeistConfig m 156 | emptyHeistConfig = HeistConfig mempty "h" True 157 | 158 | 159 | allErrors :: [Either String (TPath, v)] 160 | -> Either [String] (HashMap TPath v) 161 | allErrors tlist = 162 | case errs of 163 | [] -> Right $ Map.fromList $ rights tlist 164 | _ -> Left errs 165 | where 166 | errs = lefts tlist 167 | 168 | 169 | ------------------------------------------------------------------------------ 170 | -- | Loads templates from disk. This function returns just a template map so 171 | -- you can load multiple directories and combine the maps before initializing 172 | -- your HeistState. 173 | loadTemplates :: FilePath -> IO (Either [String] TemplateRepo) 174 | loadTemplates dir = do 175 | d <- readDirectoryWith (loadTemplate dir) dir 176 | #if MIN_VERSION_directory_tree(0,11,0) 177 | return $ allErrors $ F.fold (dirTree d) 178 | #else 179 | return $ allErrors $ F.fold (free d) 180 | #endif 181 | 182 | 183 | ------------------------------------------------------------------------------ 184 | -- | Reloads all the templates an an existing TemplateRepo. 185 | reloadTemplates :: TemplateRepo -> IO (Either [String] TemplateRepo) 186 | reloadTemplates repo = do 187 | tlist <- mapM loadOrKeep $ Map.toList repo 188 | return $ allErrors tlist 189 | where 190 | loadOrKeep (p,df) = 191 | case dfFile df of 192 | Nothing -> return $ Right (p, df) 193 | Just fp -> do 194 | df' <- loadTemplate' fp 195 | return $ fmap (p,) $ case df' of 196 | [t] -> t 197 | _ -> Left "Template repo has non-templates" 198 | 199 | 200 | ------------------------------------------------------------------------------ 201 | -- | Adds a path prefix to a templates in a map returned by loadTemplates. If 202 | -- you want to add multiple levels of directories, separate them with slashes 203 | -- as in "foo/bar". Using an empty string as a path prefix will leave the 204 | -- map unchanged. 205 | addTemplatePathPrefix :: ByteString -> TemplateRepo -> TemplateRepo 206 | addTemplatePathPrefix dir ts 207 | | B.null dir = ts 208 | | otherwise = Map.fromList $ 209 | map (\(x,y) -> (f x, y)) $ 210 | Map.toList ts 211 | where 212 | f ps = ps++splitTemplatePath dir 213 | 214 | 215 | ------------------------------------------------------------------------------ 216 | -- | Creates an empty HeistState. 217 | emptyHS :: HE.KeyGen -> HeistState m 218 | emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty Map.empty 219 | True [] [] 0 [] Nothing kg False Html "" [] False 0 220 | 221 | 222 | ------------------------------------------------------------------------------ 223 | -- | This is the main Heist initialization function. You pass in a map of all 224 | -- templates and all of your splices and it constructs and returns a 225 | -- HeistState. 226 | -- 227 | -- We don't provide functions to add either type of loadtime splices to your 228 | -- HeistState after initHeist because it doesn't make any sense unless you 229 | -- re-initialize all templates with the new splices. If you add any old-style 230 | -- runtime heist splices after calling this function, they will still work 231 | -- fine if you use Heist.Interpreted.renderTemplate. If you add any templates 232 | -- later, then those templates will be available for interpreted rendering, 233 | -- but not for compiled rendering. 234 | -- 235 | -- In the past you could add templates to your HeistState after initialization 236 | -- using its Monoid instance. Due to implementation details, this is no 237 | -- longer possible. All of your templates must be known when you call this 238 | -- function. 239 | initHeist :: Monad n 240 | => HeistConfig n 241 | -> IO (Either [String] (HeistState n)) 242 | initHeist hc = do 243 | keyGen <- HE.newKeyGen 244 | repos <- sequence $ _scTemplateLocations $ _hcSpliceConfig hc 245 | case sequence repos of 246 | Left es -> return $ Left es 247 | Right rs -> initHeist' keyGen hc (Map.unions rs) 248 | 249 | 250 | ------------------------------------------------------------------------------ 251 | mkSplicePrefix :: Text -> Text 252 | mkSplicePrefix ns 253 | | T.null ns = "" 254 | | otherwise = ns `mappend` ":" 255 | 256 | 257 | ------------------------------------------------------------------------------ 258 | initHeist' :: Monad n 259 | => HE.KeyGen 260 | -> HeistConfig n 261 | -> TemplateRepo 262 | -> IO (Either [String] (HeistState n)) 263 | initHeist' keyGen (HeistConfig sc ns enn) repo = do 264 | let empty = emptyHS keyGen 265 | let (SpliceConfig i lt c a _ f) = sc 266 | etmap <- preproc keyGen lt repo ns 267 | let prefix = mkSplicePrefix ns 268 | let eis = runHashMap $ mapK (prefix<>) i 269 | ecs = runHashMap $ mapK (prefix<>) c 270 | eas = runHashMap $ mapK (prefix<>) a 271 | let hs1 = do 272 | tmap <- etmap 273 | is <- eis 274 | cs <- ecs 275 | as <- eas 276 | return $ empty { _spliceMap = is 277 | , _templateMap = tmap 278 | , _compiledSpliceMap = cs 279 | , _attrSpliceMap = as 280 | , _splicePrefix = prefix 281 | , _errorNotBound = enn 282 | } 283 | either (return . Left) (C.compileTemplates f) hs1 284 | 285 | 286 | ------------------------------------------------------------------------------ 287 | -- | Runs preprocess on a TemplateRepo and returns the modified templates. 288 | preproc :: HE.KeyGen 289 | -> Splices (I.Splice IO) 290 | -> TemplateRepo 291 | -> Text 292 | -> IO (Either [String] TemplateRepo) 293 | preproc keyGen splices templates ns = do 294 | let esm = runHashMap splices 295 | case esm of 296 | Left errs -> return $ Left errs 297 | Right sm -> do 298 | let hs = (emptyHS keyGen) { _spliceMap = sm 299 | , _templateMap = templates 300 | , _preprocessingMode = True 301 | , _splicePrefix = mkSplicePrefix ns } 302 | let eval a = evalHeistT a (X.TextNode "") hs 303 | tPairs <- mapM (eval . preprocess) $ Map.toList templates 304 | let bad = lefts tPairs 305 | return $ if not (null bad) 306 | then Left bad 307 | else Right $ Map.fromList $ rights tPairs 308 | 309 | 310 | ------------------------------------------------------------------------------ 311 | -- | Processes a single template, running load time splices. 312 | preprocess :: (TPath, DocumentFile) 313 | -> HeistT IO IO (Either String (TPath, DocumentFile)) 314 | preprocess (tpath, docFile) = do 315 | let tname = tpathName tpath 316 | die = error $ "Preprocess failed because the template `" 317 | ++ BC.unpack tname 318 | ++ "` was not found in the template repository." 319 | !emdoc <- try $ I.evalWithDoctypes tname 320 | :: HeistT IO IO (Either SomeException (Maybe X.Document)) 321 | let f !doc = (tpath, docFile { dfDoc = doc }) 322 | return $! either (Left . show) (Right . maybe die f) emdoc 323 | 324 | 325 | ------------------------------------------------------------------------------ 326 | -- | Wrapper around initHeist that also sets up a cache tag. It sets up both 327 | -- compiled and interpreted versions of the cache tag splices. If you need to 328 | -- configure the cache tag differently than how this function does it, you 329 | -- will still probably want to pattern your approach after this function's 330 | -- implementation. 331 | initHeistWithCacheTag :: MonadIO n 332 | => HeistConfig n 333 | -> IO (Either [String] (HeistState n, CacheTagState)) 334 | initHeistWithCacheTag (HeistConfig sc ns enn) = do 335 | (ss, cts) <- liftIO mkCacheTag 336 | let tag = "cache" 337 | keyGen <- HE.newKeyGen 338 | 339 | erepos <- sequence $ _scTemplateLocations sc 340 | case sequence erepos of 341 | Left es -> return $ Left es 342 | Right repos -> do 343 | -- We have to do one preprocessing pass with the cache setup splice. This 344 | -- has to happen for both interpreted and compiled templates, so we do it 345 | -- here by itself because interpreted templates don't get the same load 346 | -- time splices as compiled templates. 347 | eRawWithCache <- preproc keyGen (tag ## ss) (Map.unions repos) ns 348 | case eRawWithCache of 349 | Left es -> return $ Left es 350 | Right rawWithCache -> do 351 | let sc' = SpliceConfig (tag #! cacheImpl cts) mempty 352 | (tag #! cacheImplCompiled cts) 353 | mempty mempty (const True) 354 | let hc = HeistConfig (mappend sc sc') ns enn 355 | hs <- initHeist' keyGen hc rawWithCache 356 | return $ fmap (,cts) hs 357 | -------------------------------------------------------------------------------- /src/Heist/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Heist.Common where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Applicative (Alternative (..)) 10 | import Control.Exception (SomeException) 11 | import qualified Control.Exception.Lifted as C 12 | import Control.Monad (liftM, mplus) 13 | import qualified Data.Attoparsec.Text as AP 14 | import Data.ByteString (ByteString) 15 | import qualified Data.ByteString as B 16 | import qualified Data.ByteString.Char8 as BC 17 | import Data.Hashable (Hashable) 18 | import Data.HashMap.Strict (HashMap) 19 | import qualified Data.HashMap.Strict as Map 20 | import Data.List (isSuffixOf, sort) 21 | import Data.Map.Syntax 22 | import Data.Maybe (isJust) 23 | import Data.Monoid ((<>)) 24 | import Data.Text (Text) 25 | import qualified Data.Text as T 26 | import Heist.Internal.Types.HeistState 27 | import System.FilePath (pathSeparator) 28 | import qualified Text.XmlHtml as X 29 | #if !MIN_VERSION_base(4,8,0) 30 | import Control.Applicative (Applicative (..), (<$>)) 31 | import Data.Monoid (Monoid (..)) 32 | #endif 33 | ------------------------------------------------------------------------------ 34 | 35 | 36 | ------------------------------------------------------------------------------ 37 | runHashMap 38 | :: Splices s 39 | -> Either [String] (HashMap T.Text s) 40 | runHashMap ms = 41 | case runMapSyntax Map.lookup Map.insert ms of 42 | Left keys -> Left $ map (T.unpack . mkMsg) keys 43 | Right hm -> Right hm 44 | where 45 | mkMsg k = "You tried to bind "<>k<>" more than once!" 46 | 47 | 48 | ------------------------------------------------------------------------------ 49 | runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v 50 | runMapNoErrors = either (const mempty) id . 51 | runMapSyntax' (\_ new _ -> Just new) Map.lookup Map.insert 52 | 53 | applySpliceMap :: HeistState n 54 | -> (HeistState n -> HashMap Text v) 55 | -> MapSyntaxM Text v a 56 | -> HashMap Text v 57 | applySpliceMap hs f = (flip Map.union (f hs)) . 58 | runMapNoErrors . 59 | mapK (mappend pre) 60 | where 61 | pre = _splicePrefix hs 62 | 63 | ------------------------------------------------------------------------------ 64 | -- | If Heist is running in fail fast mode, then this function will throw an 65 | -- exception with the second argument as the error message. Otherwise, the 66 | -- first argument will be executed to represent silent failure. 67 | -- 68 | -- This behavior allows us to fail quickly if an error crops up during 69 | -- load-time splice processing or degrade more gracefully if the error occurs 70 | -- while a user request is being processed. 71 | orError :: Monad m => HeistT n m b -> String -> HeistT n m b 72 | orError silent msg = do 73 | hs <- getHS 74 | if _preprocessingMode hs 75 | then do fullMsg <- heistErrMsg (T.pack msg) 76 | error $ T.unpack fullMsg 77 | else silent 78 | 79 | 80 | ------------------------------------------------------------------------------ 81 | -- | Prepends the location of the template currently being processed to an 82 | -- error message. 83 | heistErrMsg :: Monad m => Text -> HeistT n m Text 84 | heistErrMsg msg = do 85 | tf <- getsHS _curTemplateFile 86 | return $ (maybe "" ((`mappend` ": ") . T.pack) tf) `mappend` msg 87 | 88 | 89 | ------------------------------------------------------------------------------ 90 | -- | Adds an error message to the list of splice processing errors. 91 | tellSpliceError :: Monad m => Text -> HeistT n m () 92 | tellSpliceError msg = do 93 | hs <- getHS 94 | node <- getParamNode 95 | let spliceError = SpliceError 96 | { spliceHistory = _splicePath hs 97 | , spliceTemplateFile = _curTemplateFile hs 98 | , visibleSplices = sort $ Map.keys $ _compiledSpliceMap hs 99 | , contextNode = node 100 | , spliceMsg = msg 101 | } 102 | modifyHS (\hs' -> hs { _spliceErrors = spliceError : _spliceErrors hs' }) 103 | 104 | 105 | ------------------------------------------------------------------------------ 106 | -- | Function for showing a TPath. 107 | showTPath :: TPath -> String 108 | showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName 109 | 110 | 111 | ------------------------------------------------------------------------------ 112 | -- | Convert a TPath into a ByteString path. 113 | tpathName :: TPath -> ByteString 114 | tpathName = BC.intercalate "/" . reverse 115 | 116 | 117 | ------------------------------------------------------------------------------ 118 | -- | Sets the current template file. 119 | setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n 120 | setCurTemplateFile Nothing ts = ts 121 | setCurTemplateFile fp ts = ts { _curTemplateFile = fp } 122 | 123 | 124 | ------------------------------------------------------------------------------ 125 | setCurContext :: TPath -> HeistState n -> HeistState n 126 | setCurContext tp ts = ts { _curContext = tp } 127 | 128 | 129 | ------------------------------------------------------------------------------ 130 | -- | Parser for attribute variable substitution. 131 | attParser :: AP.Parser [AttAST] 132 | attParser = liftM ($! []) (loop id) 133 | where 134 | append !dl !x = dl . (x:) 135 | 136 | loop !dl = go id 137 | where 138 | finish subDL = let !txt = T.concat $! subDL [] 139 | lit = Literal $! T.concat $! subDL [] 140 | in return $! if T.null txt 141 | then dl 142 | else append dl lit 143 | 144 | go !subDL = (gobbleText >>= go . append subDL) 145 | <|> (AP.endOfInput *> finish subDL) 146 | <|> (do 147 | idp <- identParser 148 | dl' <- finish subDL 149 | loop $! append dl' idp) 150 | 151 | gobbleText = AP.takeWhile1 (AP.notInClass "$") 152 | 153 | identParser = AP.char '$' *> (ident <|> return (Literal "$")) 154 | ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}") 155 | 156 | 157 | ------------------------------------------------------------------------------ 158 | -- | Converts a path into an array of the elements in reverse order. If the 159 | -- path is absolute, we need to remove the leading slash so the split doesn't 160 | -- leave @\"\"@ as the last element of the TPath. 161 | -- 162 | -- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial 163 | splitPathWith :: Char -> ByteString -> TPath 164 | splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path) 165 | where 166 | path = if BC.head p == s then BC.tail p else p 167 | 168 | 169 | ------------------------------------------------------------------------------ 170 | -- | Converts a path into an array of the elements in reverse order using the 171 | -- path separator of the local operating system. See 'splitPathWith' for more 172 | -- details. 173 | splitLocalPath :: ByteString -> TPath 174 | splitLocalPath = splitPathWith pathSeparator 175 | 176 | 177 | ------------------------------------------------------------------------------ 178 | -- | Converts a path into an array of the elements in reverse order using a 179 | -- forward slash (/) as the path separator. See 'splitPathWith' for more 180 | -- details. 181 | splitTemplatePath :: ByteString -> TPath 182 | splitTemplatePath = splitPathWith '/' 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | -- | Convenience function for looking up a template. 187 | lookupTemplate :: ByteString 188 | -> HeistState n 189 | -> (HeistState n -> HashMap TPath t) 190 | -> Maybe (t, TPath) 191 | lookupTemplate nameStr ts tm = f (tm ts) path name 192 | where 193 | (name, p) = case splitTemplatePath nameStr of 194 | [] -> ("", []) 195 | x:xs -> (x, xs) 196 | ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts 197 | path = p ++ ctx 198 | f = if '/' `BC.elem` nameStr 199 | then singleLookup 200 | else traversePath 201 | 202 | 203 | ------------------------------------------------------------------------------ 204 | -- | Returns 'True' if the given template can be found in the heist state. 205 | hasTemplate :: ByteString -> HeistState n -> Bool 206 | hasTemplate nameStr ts = 207 | isJust $ lookupTemplate nameStr ts _templateMap 208 | 209 | 210 | ------------------------------------------------------------------------------ 211 | -- | Does a single template lookup without cascading up. 212 | singleLookup :: (Eq a, Hashable a) 213 | => HashMap [a] t -> [a] -> a -> Maybe (t, [a]) 214 | singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm 215 | 216 | 217 | ------------------------------------------------------------------------------ 218 | -- | Searches for a template by looking in the full path then backing up into 219 | -- each of the parent directories until the template is found. 220 | traversePath :: (Eq a, Hashable a) 221 | => HashMap [a] t -> [a] -> a -> Maybe (t, [a]) 222 | traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm) 223 | traversePath tm path name = 224 | singleLookup tm path name `mplus` 225 | traversePath tm (tail path) name 226 | 227 | 228 | ------------------------------------------------------------------------------ 229 | -- | Maps a splice generating function over a list and concatenates the 230 | -- results. This function now has a more general type signature so it works 231 | -- with both compiled and interpreted splices. The old type signature was 232 | -- this: 233 | -- 234 | -- > mapSplices :: (Monad n) 235 | -- > => (a -> Splice n n) 236 | -- > -> [a] 237 | -- > -> Splice n n 238 | mapSplices :: (Monad m, Monoid b) 239 | => (a -> m b) 240 | -- ^ Splice generating function 241 | -> [a] 242 | -- ^ List of items to generate splices for 243 | -> m b 244 | -- ^ The result of all splices concatenated together. 245 | mapSplices f vs = liftM mconcat $ mapM f vs 246 | {-# INLINE mapSplices #-} 247 | 248 | 249 | ------------------------------------------------------------------------------ 250 | -- | Gets the current context 251 | getContext :: Monad m => HeistT n m TPath 252 | getContext = getsHS _curContext 253 | 254 | 255 | ------------------------------------------------------------------------------ 256 | -- | Gets the full path to the file holding the template currently being 257 | -- processed. Returns Nothing if the template is not associated with a file 258 | -- on disk or if there is no template being processed. 259 | getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath) 260 | getTemplateFilePath = getsHS _curTemplateFile 261 | 262 | 263 | ------------------------------------------------------------------------------ 264 | -- | Loads a template with the specified path and filename. The 265 | -- template is only loaded if it has a ".tpl" or ".xtpl" extension. 266 | loadTemplate :: String -- ^ path of the template root 267 | -> String -- ^ full file path (includes the template root) 268 | -> IO [Either String (TPath, DocumentFile)] --TemplateMap 269 | loadTemplate templateRoot fname = do 270 | c <- loadTemplate' fname 271 | return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c 272 | where -- tName is path relative to the template root directory 273 | isHTMLTemplate = ".tpl" `isSuffixOf` fname 274 | correction = if last templateRoot == '/' then 0 else 1 275 | extLen = if isHTMLTemplate then 4 else 5 276 | tName = drop ((length templateRoot)+correction) $ 277 | -- We're only dropping the template root, not the whole path 278 | take ((length fname) - extLen) fname 279 | 280 | 281 | ------------------------------------------------------------------------------ 282 | -- | Loads a template at the specified path, choosing the appropriate parser 283 | -- based on the file extension. The template is only loaded if it has a 284 | -- \".tpl\" or \".xtpl\" extension. Returns an empty list if the extension 285 | -- doesn't match. 286 | loadTemplate' :: String -> IO [Either String DocumentFile] 287 | loadTemplate' fullDiskPath 288 | | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath 289 | | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath 290 | | otherwise = return [] 291 | where 292 | isHTMLTemplate = ".tpl" `isSuffixOf` fullDiskPath 293 | isXMLTemplate = ".xtpl" `isSuffixOf` fullDiskPath 294 | 295 | 296 | ------------------------------------------------------------------------------ 297 | -- | Type synonym for parsers. 298 | type ParserFun = String -> ByteString -> Either String X.Document 299 | 300 | 301 | ------------------------------------------------------------------------------ 302 | -- | Reads an HTML or XML template from disk. 303 | getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) 304 | getDocWith parser f = do 305 | bs <- C.catch (liftM Right $ B.readFile f) 306 | (\(e::SomeException) -> return $ Left $ show e) 307 | 308 | let eitherDoc = either Left (parser f) bs 309 | return $ either (\s -> Left $ f ++ " " ++ s) 310 | (\d -> Right $ DocumentFile d (Just f)) eitherDoc 311 | 312 | 313 | ------------------------------------------------------------------------------ 314 | -- | Reads an HTML template from disk. 315 | getDoc :: String -> IO (Either String DocumentFile) 316 | getDoc = getDocWith X.parseHTML 317 | 318 | 319 | ------------------------------------------------------------------------------ 320 | -- | Reads an XML template from disk. 321 | getXMLDoc :: String -> IO (Either String DocumentFile) 322 | getXMLDoc = getDocWith X.parseXML 323 | 324 | 325 | ------------------------------------------------------------------------------ 326 | -- | Sets the templateMap in a HeistState. 327 | setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n 328 | setTemplates m ts = ts { _templateMap = m } 329 | 330 | 331 | ------------------------------------------------------------------------------ 332 | -- | Adds a template to the heist state. 333 | insertTemplate :: TPath 334 | -> DocumentFile 335 | -> HeistState n 336 | -> HeistState n 337 | insertTemplate p t st = 338 | setTemplates (Map.insert p t (_templateMap st)) st 339 | 340 | 341 | ------------------------------------------------------------------------------ 342 | -- Gives the MIME type for a 'X.Document' 343 | mimeType :: X.Document -> MIMEType 344 | mimeType d = case d of 345 | (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e 346 | (X.XmlDocument e _ _) -> "text/xml;charset=" `BC.append` enc e 347 | where 348 | enc X.UTF8 = "utf-8" 349 | -- Should not include byte order designation for UTF-16 since 350 | -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3) 351 | enc X.UTF16BE = "utf-16" 352 | enc X.UTF16LE = "utf-16" 353 | enc X.ISO_8859_1 = "iso-8859-1" 354 | 355 | 356 | ------------------------------------------------------------------------------ 357 | -- | Binds a set of new splice declarations within a 'HeistState'. 358 | bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind 359 | -> HeistState n -- ^ start state 360 | -> HeistState n 361 | bindAttributeSplices ss hs = 362 | hs { _attrSpliceMap = applySpliceMap hs _attrSpliceMap ss } 363 | 364 | ------------------------------------------------------------------------------ 365 | -- | Mappends a doctype to the state. 366 | addDoctype :: Monad m => [X.DocType] -> HeistT n m () 367 | addDoctype dt = do 368 | modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt }) 369 | 370 | 371 | -------------------------------------------------------------------------------- /src/Heist/Compiled.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Compiled splices are similar to the original Heist (interpreted) splices, but 4 | without the high performance costs of traversing a DOM at runtime. Compiled 5 | splices do all of their DOM processing at load time. They are compiled to 6 | produce a runtime computation that generates a ByteString Builder. This 7 | preserves the ability to write splices that access runtime information from 8 | the HTTP request, database, etc. 9 | 10 | If you import both this module and "Heist.Interpreted" in the same file, then 11 | you will need to import them qualified. 12 | 13 | -} 14 | 15 | module Heist.Compiled 16 | ( 17 | -- * High level compiled splice API 18 | Splice 19 | , renderTemplate 20 | , codeGen 21 | , runChildren 22 | 23 | -- * Functions for manipulating lists of compiled splices 24 | , textSplice 25 | , nodeSplice 26 | , xmlNodeSplice 27 | , htmlNodeSplice 28 | , pureSplice 29 | 30 | , deferMany 31 | , defer 32 | , deferMap 33 | , mayDeferMap 34 | , bindLater 35 | , withSplices 36 | , manyWithSplices 37 | , manyWith 38 | , withLocalSplices 39 | 40 | -- * Constructing Chunks 41 | -- $yieldOverview 42 | , yieldPure 43 | , yieldRuntime 44 | , yieldRuntimeEffect 45 | , yieldPureText 46 | , yieldRuntimeText 47 | 48 | -- * Running nodes and splices 49 | , runNodeList 50 | , runNode 51 | , runAttributes 52 | , runAttributesRaw 53 | , callTemplate 54 | 55 | ) where 56 | 57 | import Heist.Compiled.Internal 58 | 59 | -- $yieldOverview 60 | -- The internals of the Chunk data type are deliberately not exported because 61 | -- we want to hide the underlying implementation as much as possible. The 62 | -- @yield...@ functions give you lower level construction of DLists of Chunks. 63 | -- 64 | -- Most of the time you will use these functions composed with return to 65 | -- generate a Splice. But we decided not to include the return in these 66 | -- functions to allow you to work with the DLists purely. 67 | -------------------------------------------------------------------------------- /src/Heist/Compiled/LowLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE NoMonomorphismRestriction #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | 9 | module Heist.Compiled.LowLevel 10 | ( 11 | -- * Lower level promise functions 12 | Promise 13 | , newEmptyPromise 14 | , getPromise 15 | , putPromise 16 | , adjustPromise 17 | 18 | ) where 19 | 20 | import Heist.Compiled.Internal 21 | -------------------------------------------------------------------------------- /src/Heist/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | {-| 11 | 12 | Internal types and accessors. There are no guarantees that heist will 13 | preserve backwards compatibility for symbols in this module. If you use them, 14 | no complaining when your code breaks. 15 | 16 | -} 17 | 18 | module Heist.Internal.Types 19 | ( module Heist.Internal.Types.HeistState 20 | , module Heist.Internal.Types 21 | ) where 22 | 23 | ------------------------------------------------------------------------------ 24 | import Data.HashMap.Strict (HashMap) 25 | import Data.Text (Text) 26 | 27 | #if !MIN_VERSION_base(4,8,0) 28 | import Control.Applicative 29 | #endif 30 | #if !MIN_VERSION_base(4,11,0) 31 | import Data.Semigroup 32 | #endif 33 | 34 | ------------------------------------------------------------------------------ 35 | import qualified Heist.Compiled.Internal as C 36 | import qualified Heist.Interpreted.Internal as I 37 | import Heist.Internal.Types.HeistState 38 | ------------------------------------------------------------------------------ 39 | 40 | 41 | ------------------------------------------------------------------------------ 42 | type TemplateRepo = HashMap TPath DocumentFile 43 | 44 | 45 | ------------------------------------------------------------------------------ 46 | -- | An IO action for getting a template repo from this location. By not just 47 | -- using a directory path here, we support templates loaded from a database, 48 | -- retrieved from the network, or anything else you can think of. 49 | type TemplateLocation = IO (Either [String] TemplateRepo) 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- | My lens creation function to avoid a dependency on lens. 54 | lens :: Functor f => (t1 -> t) -> (t1 -> a -> b) -> (t -> f a) -> t1 -> f b 55 | lens sa sbt afb s = sbt s <$> afb (sa s) 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -- | The splices and templates Heist will use. To bind a splice simply 60 | -- include it in the appropriate place here. 61 | data SpliceConfig m = SpliceConfig 62 | { _scInterpretedSplices :: Splices (I.Splice m) 63 | -- ^ Interpreted splices are the splices that Heist has always had. 64 | -- They return a list of nodes and are processed at runtime. 65 | , _scLoadTimeSplices :: Splices (I.Splice IO) 66 | -- ^ Load time splices are like interpreted splices because they 67 | -- return a list of nodes. But they are like compiled splices because 68 | -- they are processed once at load time. All of Heist's built-in 69 | -- splices should be used as load time splices. 70 | , _scCompiledSplices :: Splices (C.Splice m) 71 | -- ^ Compiled splices return a DList of Chunks and are processed at 72 | -- load time to generate a runtime monad action that will be used to 73 | -- render the template. 74 | , _scAttributeSplices :: Splices (AttrSplice m) 75 | -- ^ Attribute splices are bound to attribute names and return a list 76 | -- of attributes. 77 | , _scTemplateLocations :: [TemplateLocation] 78 | -- ^ A list of all the locations that Heist should get its templates 79 | -- from. 80 | , _scCompiledTemplateFilter :: TPath -> Bool 81 | -- ^ Predicate function to control which templates to compile. Using 82 | -- templates filtered out with this is still possible via 83 | -- callTemplate. 84 | } 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- | Lens for interpreted splices 89 | -- :: Simple Lens (SpliceConfig m) (Splices (I.Splice m)) 90 | scInterpretedSplices 91 | :: Functor f 92 | => (Splices (I.Splice m) -> f (Splices (I.Splice m))) 93 | -> SpliceConfig m -> f (SpliceConfig m) 94 | scInterpretedSplices = lens _scInterpretedSplices setter 95 | where 96 | setter sc v = sc { _scInterpretedSplices = v } 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- | Lens for load time splices 101 | -- :: Simple Lens (SpliceConfig m) (Splices (I.Splice IO)) 102 | scLoadTimeSplices 103 | :: Functor f 104 | => (Splices (I.Splice IO) -> f (Splices (I.Splice IO))) 105 | -> SpliceConfig m -> f (SpliceConfig m) 106 | scLoadTimeSplices = lens _scLoadTimeSplices setter 107 | where 108 | setter sc v = sc { _scLoadTimeSplices = v } 109 | 110 | 111 | ------------------------------------------------------------------------------ 112 | -- | Lens for complied splices 113 | -- :: Simple Lens (SpliceConfig m) (Splices (C.Splice m)) 114 | scCompiledSplices 115 | :: Functor f 116 | => (Splices (C.Splice m) -> f (Splices (C.Splice m))) 117 | -> SpliceConfig m -> f (SpliceConfig m) 118 | scCompiledSplices = lens _scCompiledSplices setter 119 | where 120 | setter sc v = sc { _scCompiledSplices = v } 121 | 122 | 123 | ------------------------------------------------------------------------------ 124 | -- | Lens for attribute splices 125 | -- :: Simple Lens (SpliceConfig m) (Splices (AttrSplice m)) 126 | scAttributeSplices 127 | :: Functor f 128 | => (Splices (AttrSplice m) -> f (Splices (AttrSplice m))) 129 | -> SpliceConfig m -> f (SpliceConfig m) 130 | scAttributeSplices = lens _scAttributeSplices setter 131 | where 132 | setter sc v = sc { _scAttributeSplices = v } 133 | 134 | 135 | ------------------------------------------------------------------------------ 136 | -- | Lens for template locations 137 | -- :: Simple Lens (SpliceConfig m) [TemplateLocation] 138 | scTemplateLocations 139 | :: Functor f 140 | => ([TemplateLocation] -> f [TemplateLocation]) 141 | -> SpliceConfig m -> f (SpliceConfig m) 142 | scTemplateLocations = lens _scTemplateLocations setter 143 | where 144 | setter sc v = sc { _scTemplateLocations = v } 145 | 146 | 147 | ------------------------------------------------------------------------------ 148 | -- | Lens for compiled template filter 149 | -- :: Simple Lens (SpliceConfig m) (TBool -> Bool) 150 | scCompiledTemplateFilter 151 | :: Functor f 152 | => ((TPath -> Bool) -> f (TPath -> Bool)) 153 | -> SpliceConfig m -> f (SpliceConfig m) 154 | scCompiledTemplateFilter = lens _scCompiledTemplateFilter setter 155 | where 156 | setter sc v = sc { _scCompiledTemplateFilter = v } 157 | 158 | 159 | instance Semigroup (SpliceConfig m) where 160 | SpliceConfig a1 b1 c1 d1 e1 f1 <> SpliceConfig a2 b2 c2 d2 e2 f2 = 161 | SpliceConfig (a1 <> a2) (b1 <> b2) (c1 <> c2) 162 | (d1 <> d2) (e1 <> e2) (\x -> f1 x && f2 x) 163 | 164 | instance Monoid (SpliceConfig m) where 165 | mempty = SpliceConfig mempty mempty mempty mempty mempty (const True) 166 | #if !MIN_VERSION_base(4,11,0) 167 | mappend = (<>) 168 | #endif 169 | 170 | 171 | data HeistConfig m = HeistConfig 172 | { _hcSpliceConfig :: SpliceConfig m 173 | -- ^ Splices and templates 174 | , _hcNamespace :: Text 175 | -- ^ A namespace to use for all tags that are bound to splices. Use 176 | -- empty string for no namespace. 177 | , _hcErrorNotBound :: Bool 178 | -- ^ Whether to throw an error when a tag wih the heist namespace does 179 | -- not correspond to a bound splice. When not using a namespace, this 180 | -- flag is ignored. 181 | } 182 | 183 | 184 | ------------------------------------------------------------------------------ 185 | -- | Lens for the SpliceConfig 186 | -- :: Simple Lens (HeistConfig m) (SpliceConfig m) 187 | hcSpliceConfig 188 | :: Functor f 189 | => ((SpliceConfig m) -> f (SpliceConfig m)) 190 | -> HeistConfig m -> f (HeistConfig m) 191 | hcSpliceConfig = lens _hcSpliceConfig setter 192 | where 193 | setter hc v = hc { _hcSpliceConfig = v } 194 | 195 | 196 | ------------------------------------------------------------------------------ 197 | -- | Lens for the namespace 198 | -- :: Simple Lens (HeistConfig m) Text 199 | hcNamespace 200 | :: Functor f 201 | => (Text -> f Text) 202 | -> HeistConfig m -> f (HeistConfig m) 203 | hcNamespace = lens _hcNamespace setter 204 | where 205 | setter hc v = hc { _hcNamespace = v } 206 | 207 | 208 | ------------------------------------------------------------------------------ 209 | -- | Lens for the namespace error flag 210 | -- :: Simple Lens (HeistConfig m) Bool 211 | hcErrorNotBound 212 | :: Functor f 213 | => (Bool -> f Bool) 214 | -> HeistConfig m -> f (HeistConfig m) 215 | hcErrorNotBound = lens _hcErrorNotBound setter 216 | where 217 | setter hc v = hc { _hcErrorNotBound = v } 218 | 219 | 220 | ------------------------------------------------------------------------------ 221 | -- | Lens for interpreted splices 222 | -- :: Simple Lens (HeistConfig m) (Splices (I.Splice m)) 223 | hcInterpretedSplices 224 | :: Functor f 225 | => (Splices (I.Splice m) -> f (Splices (I.Splice m))) 226 | -> HeistConfig m -> f (HeistConfig m) 227 | hcInterpretedSplices = hcSpliceConfig . scInterpretedSplices 228 | 229 | 230 | ------------------------------------------------------------------------------ 231 | -- | Lens for load time splices 232 | -- :: Simple Lens (HeistConfig m) (Splices (I.Splice IO)) 233 | hcLoadTimeSplices 234 | :: Functor f 235 | => (Splices (I.Splice IO) -> f (Splices (I.Splice IO))) 236 | -> HeistConfig m -> f (HeistConfig m) 237 | hcLoadTimeSplices = hcSpliceConfig . scLoadTimeSplices 238 | 239 | 240 | ------------------------------------------------------------------------------ 241 | -- | Lens for compiled splices 242 | -- :: Simple Lens (HeistConfig m) (Splices (C.Splice m)) 243 | hcCompiledSplices 244 | :: Functor f 245 | => (Splices (C.Splice m) -> f (Splices (C.Splice m))) 246 | -> HeistConfig m -> f (HeistConfig m) 247 | hcCompiledSplices = hcSpliceConfig . scCompiledSplices 248 | 249 | 250 | ------------------------------------------------------------------------------ 251 | -- | Lens for attribute splices 252 | -- :: Simple Lens (HeistConfig m) (Splices (AttrSplice m)) 253 | hcAttributeSplices 254 | :: Functor f 255 | => (Splices (AttrSplice m) -> f (Splices (AttrSplice m))) 256 | -> HeistConfig m -> f (HeistConfig m) 257 | hcAttributeSplices = hcSpliceConfig . scAttributeSplices 258 | 259 | 260 | ------------------------------------------------------------------------------ 261 | -- | Lens for template locations 262 | -- :: Simple Lens (HeistConfig m) [TemplateLocation] 263 | hcTemplateLocations 264 | :: Functor f 265 | => ([TemplateLocation] -> f [TemplateLocation]) 266 | -> HeistConfig m -> f (HeistConfig m) 267 | hcTemplateLocations = hcSpliceConfig . scTemplateLocations 268 | 269 | 270 | ------------------------------------------------------------------------------ 271 | -- | Lens for compiled template filter 272 | -- :: Simple Lens (SpliceConfig m) (TBool -> Bool) 273 | hcCompiledTemplateFilter 274 | :: Functor f 275 | => ((TPath -> Bool) -> f (TPath -> Bool)) 276 | -> HeistConfig m -> f (HeistConfig m) 277 | hcCompiledTemplateFilter = hcSpliceConfig . scCompiledTemplateFilter 278 | 279 | 280 | -------------------------------------------------------------------------------- /src/Heist/Interpreted.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This module defines the API for writing and working with interpreted splices. 4 | It exports some of the same symbols as "Heist.Compiled", so you will probably 5 | want to import it qualified. 6 | 7 | Interpreted splices can be thought of as a function @Node -> m [Node]@. Heist 8 | then substitutes the resulting list of nodes into your template in place of 9 | the input node. 'Splice' is implemented as a type synonym @type Splice m = 10 | HeistT m [Node]@, and 'HeistT' has a function 'getParamNode' that lets you get 11 | the input node. 12 | 13 | Suppose you have a place on your page where you want to display a link with 14 | the text \"Logout username\" if the user is currently logged in or a link to 15 | the login page if no user is logged in. Assume you have a function 16 | @getUser :: MyAppMonad (Maybe Text)@ that gets the current user. 17 | You can implement this functionality with a 'Splice' as follows: 18 | 19 | > import Blaze.ByteString.Builder 20 | > import Data.ByteString.Char8 (ByteString) 21 | > import qualified Data.ByteString.Char8 as B 22 | > import Data.Text (Text) 23 | > import qualified Data.Text as T 24 | > import qualified Text.XmlHtml as X 25 | > 26 | > import qualified Heist.Interpreted as I 27 | > 28 | > link :: Text -> Text -> X.Node 29 | > link target text = X.Element "a" [("href", target)] [X.TextNode text] 30 | > 31 | > loginLink :: X.Node 32 | > loginLink = link "/login" "Login" 33 | > 34 | > logoutLink :: Text -> X.Node 35 | > logoutLink user = link "/logout" (T.append "Logout " user) 36 | > 37 | > loginLogoutSplice :: I.Splice MyAppMonad 38 | > loginLogoutSplice = do 39 | > user <- lift getUser 40 | > return [maybe loginLink logoutLink user] 41 | > 42 | 43 | -} 44 | 45 | module Heist.Interpreted 46 | ( 47 | Splice 48 | 49 | -- * HeistState Functions 50 | , addTemplate 51 | , addXMLTemplate 52 | , lookupSplice 53 | , bindSplice 54 | , bindSplices 55 | , bindAttributeSplices 56 | 57 | -- * Functions for creating splices 58 | , textSplice 59 | , runChildren 60 | , runChildrenWith 61 | , runChildrenWithTrans 62 | , runChildrenWithTemplates 63 | , runChildrenWithText 64 | , mapSplices 65 | 66 | -- * HeistT functions 67 | , stopRecursion 68 | , runNode 69 | , runAttributes 70 | , runNodeList 71 | , evalTemplate 72 | , bindStrings 73 | , bindString 74 | , callTemplate 75 | , callTemplateWithText 76 | , renderTemplate 77 | , renderTemplateToDoc 78 | , renderWithArgs 79 | ) where 80 | 81 | import Heist.Interpreted.Internal 82 | import Heist.Common (mapSplices, bindAttributeSplices) 83 | 84 | -------------------------------------------------------------------------------- /src/Heist/Splices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Heist.Splices 4 | ( ifISplice 5 | , ifCSplice 6 | , ifElseISplice 7 | , ifElseCSplice 8 | , module Heist.Splices.Apply 9 | , module Heist.Splices.Bind 10 | , module Heist.Splices.Cache 11 | , module Heist.Splices.Html 12 | , module Heist.Splices.Ignore 13 | , module Heist.Splices.Markdown 14 | ) where 15 | 16 | #if !MIN_VERSION_base(4,8,0) 17 | import Data.Monoid (Monoid(..)) 18 | #endif 19 | 20 | import qualified Heist.Compiled as C 21 | import qualified Heist.Interpreted as I 22 | import Heist.Splices.Apply 23 | import Heist.Splices.Bind 24 | import Heist.Splices.Cache 25 | import Heist.Splices.Html 26 | import Heist.Splices.Ignore 27 | import Heist.Splices.Markdown 28 | import Heist.Internal.Types.HeistState 29 | import qualified Text.XmlHtml as X 30 | 31 | ------------------------------------------------------------------------------ 32 | -- | Run the splice contents if given condition is True, make splice disappear 33 | -- if not. 34 | ifISplice :: Monad m => Bool -> I.Splice m 35 | ifISplice cond = 36 | case cond of 37 | False -> return [] 38 | True -> I.runChildren 39 | 40 | 41 | ------------------------------------------------------------------------------ 42 | -- | Function for constructing if splices that use a runtime predicate 43 | -- function to determine whether the node's children should be rendered. 44 | ifCSplice :: Monad m 45 | => (t -> Bool) 46 | -> RuntimeSplice m t 47 | -> C.Splice m 48 | ifCSplice predicate runtime = do 49 | chunks <- C.runChildren 50 | return $ C.yieldRuntime $ do 51 | a <- runtime 52 | if predicate a 53 | then 54 | C.codeGen chunks 55 | else 56 | return mempty 57 | 58 | 59 | ------------------------------------------------------------------------------ 60 | -- | Implements an if\/then\/else conditional splice. It splits its children 61 | -- around the \ element to get the markup to be used for the two cases. 62 | ifElseISplice :: Monad m => Bool -> I.Splice m 63 | ifElseISplice cond = getParamNode >>= (rewrite . X.childNodes) 64 | where 65 | rewrite nodes = 66 | let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes 67 | in I.runNodeList $ if cond then ns else (drop 1 ns') 68 | 69 | 70 | ------------------------------------------------------------------------------ 71 | -- | Implements an if\/then\/else conditional splice. It splits its children 72 | -- around the \ element to get the markup to be used for the two cases. 73 | ifElseCSplice :: Monad m => Bool -> C.Splice m 74 | ifElseCSplice cond = getParamNode >>= (rewrite . X.childNodes) 75 | where rewrite nodes = 76 | let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes 77 | in C.runNodeList $ if cond then ns else (drop 1 ns') 78 | -------------------------------------------------------------------------------- /src/Heist/Splices/Apply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Heist.Splices.Apply where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Data.Maybe 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | import qualified Text.XmlHtml as X 11 | 12 | ------------------------------------------------------------------------------ 13 | import Heist.Common 14 | import Heist.Interpreted.Internal 15 | import Heist.Internal.Types.HeistState 16 | 17 | 18 | ------------------------------------------------------------------------------ 19 | -- | Default name for the apply splice. 20 | applyTag :: Text 21 | applyTag = "apply" 22 | 23 | 24 | ------------------------------------------------------------------------------ 25 | -- | Default attribute name for the apply tag. 26 | applyAttr :: Text 27 | applyAttr = "template" 28 | 29 | 30 | ------------------------------------------------------------------------------ 31 | -- | 32 | rawApply :: (Monad n) 33 | => Text 34 | -> [X.Node] 35 | -> Maybe FilePath 36 | -> TPath 37 | -> [X.Node] 38 | -> Splice n 39 | rawApply paramTag calledNodes templateFile newContext paramNodes = do 40 | hs <- getHS -- Can't use localHS here because the modifier is not pure 41 | processedParams <- runNodeList paramNodes 42 | 43 | -- apply should do a bottom-up traversal, so we run the called nodes 44 | -- before doing substitution. 45 | modifyHS (setCurContext newContext . setCurTemplateFile templateFile) 46 | 47 | let process = concatMap (treeMap processedParams) 48 | if _recursionDepth hs < mAX_RECURSION_DEPTH 49 | then do modRecursionDepth (+1) 50 | res <- runNodeList calledNodes 51 | restoreHS hs 52 | return $! process res 53 | else do restoreHS hs 54 | (return []) `orError` err 55 | where 56 | err = "template recursion exceeded max depth, "++ 57 | "you probably have infinite splice recursion!" :: String 58 | treeMap :: [X.Node] -> X.Node -> [X.Node] 59 | treeMap ns n@(X.Element nm _ cs) 60 | | nm == paramTag = ns 61 | | otherwise = [n { X.elementChildren = cs' }] 62 | where 63 | !cs' = concatMap (treeMap ns) cs 64 | treeMap _ n = [n] 65 | 66 | 67 | ------------------------------------------------------------------------------ 68 | -- | Applies a template as if the supplied nodes were the children of the 69 | -- tag. 70 | applyNodes :: Monad n => Template -> Text -> Splice n 71 | applyNodes nodes template = do 72 | hs <- getHS 73 | maybe (return [] `orError` err) 74 | (\(t,ctx) -> do 75 | addDoctype $ maybeToList $ X.docType $ dfDoc t 76 | rawApply "apply-content" (X.docContent $ dfDoc t) 77 | (dfFile t) ctx nodes) 78 | (lookupTemplate (T.encodeUtf8 template) hs _templateMap) 79 | where 80 | err = "apply tag cannot find template \""++(T.unpack template)++"\"" 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | -- | Implementation of the apply splice. 85 | applyImpl :: Monad n => Splice n 86 | applyImpl = do 87 | node <- getParamNode 88 | let err = "must supply \"" ++ T.unpack applyAttr ++ 89 | "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" 90 | case X.getAttribute applyAttr node of 91 | Nothing -> return [] `orError` err 92 | Just template -> applyNodes (X.childNodes node) template 93 | 94 | 95 | ------------------------------------------------------------------------------ 96 | -- | This splice crashes with an error message. Its purpose is to provide a 97 | -- load-time warning to anyone still using the old content tag in their 98 | -- templates. In Heist 0.10, tho content tag was replaced by two separate 99 | -- apply-content and bind-content tags used by the apply and bind splices 100 | -- respectively. 101 | deprecatedContentCheck :: Monad m => Splice m 102 | deprecatedContentCheck = 103 | return [] `orError` unwords 104 | [" tag deprecated. Use" 105 | ," or " 106 | ] 107 | 108 | -------------------------------------------------------------------------------- /src/Heist/Splices/Bind.hs: -------------------------------------------------------------------------------- 1 | module Heist.Splices.Bind where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Text (Text) 5 | import qualified Data.Text as T 6 | import qualified Text.XmlHtml as X 7 | 8 | ------------------------------------------------------------------------------ 9 | import Heist.Common 10 | import Heist.Interpreted.Internal 11 | import Heist.Splices.Apply 12 | import Heist.Internal.Types.HeistState 13 | 14 | -- | Default name for the bind splice. 15 | bindTag :: Text 16 | bindTag = "bind" 17 | 18 | 19 | ------------------------------------------------------------------------------ 20 | -- | Default attribute name for the bind tag. 21 | bindAttr :: Text 22 | bindAttr = "tag" 23 | 24 | 25 | ------------------------------------------------------------------------------ 26 | -- | Implementation of the bind splice. 27 | bindImpl :: Monad n => Splice n 28 | bindImpl = do 29 | node <- getParamNode 30 | let err = "must supply \"" ++ T.unpack bindAttr ++ 31 | "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" 32 | maybe (return () `orError` err) 33 | (add node) 34 | (X.getAttribute bindAttr node) 35 | return [] 36 | where 37 | add node nm = modifyHS $ bindSplice nm $ do 38 | caller <- getParamNode 39 | ctx <- getContext 40 | rawApply "bind-content" (X.childNodes node) 41 | Nothing ctx (X.childNodes caller) 42 | 43 | -------------------------------------------------------------------------------- /src/Heist/Splices/BindStrict.hs: -------------------------------------------------------------------------------- 1 | module Heist.Splices.BindStrict where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Text (Text) 5 | import qualified Data.Text as T 6 | import qualified Text.XmlHtml as X 7 | 8 | ------------------------------------------------------------------------------ 9 | import Heist.Common 10 | import Heist.Interpreted.Internal 11 | import Heist.Splices.Apply 12 | import Heist.Splices.Bind 13 | import Heist.Internal.Types.HeistState 14 | 15 | -- | Default name for the bind splice. 16 | bindStrictTag :: Text 17 | bindStrictTag = "bindStrict" 18 | 19 | 20 | ------------------------------------------------------------------------------ 21 | -- | Implementation of the bind splice. 22 | bindStrictImpl :: Monad n => Splice n 23 | bindStrictImpl = do 24 | node <- getParamNode 25 | cs <- runChildren 26 | let err = "must supply \"" ++ T.unpack bindAttr ++ 27 | "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" 28 | maybe (return () `orError` err) (add cs) 29 | (X.getAttribute bindAttr node) 30 | return [] 31 | 32 | where 33 | add cs nm = modifyHS $ bindSplice nm $ do 34 | caller <- getParamNode 35 | ctx <- getContext 36 | rawApply "bindstrict-content" cs Nothing ctx (X.childNodes caller) 37 | -------------------------------------------------------------------------------- /src/Heist/Splices/Cache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | -- | The \"cache\" splice ensures that its contents are cached and only 6 | -- evaluated periodically. The cached contents are returned every time the 7 | -- splice is referenced. 8 | -- 9 | -- Use the ttl attribute to set the amount of time between reloads. The ttl 10 | -- value should be a positive integer followed by a single character 11 | -- specifying the units. Valid units are a single letter abbreviation for one 12 | -- of seconds, minutes, hours, days, and weeks. If the ttl string is invalid 13 | -- or the ttl attribute is not specified, the cache is never refreshed unless 14 | -- explicitly cleared with clearCacheTagState. The compiled splice version of 15 | -- the cache tag does not require a cache tag state, so clearCacheTagState 16 | -- will not work for compiled cache tags. 17 | 18 | module Heist.Splices.Cache 19 | ( CacheTagState 20 | , cacheImpl 21 | , cacheImplCompiled 22 | , mkCacheTag 23 | , clearCacheTagState 24 | ) where 25 | 26 | ------------------------------------------------------------------------------ 27 | import Blaze.ByteString.Builder 28 | import Control.Concurrent 29 | import Control.Monad 30 | import Control.Monad.Trans 31 | import Data.IORef 32 | import qualified Data.HashMap.Strict as H 33 | import Data.HashMap.Strict (HashMap) 34 | import qualified Data.HashSet as Set 35 | import Data.Text (Text) 36 | import qualified Data.Text as T 37 | import Data.Text.Read 38 | import Data.Time.Clock 39 | import System.Random 40 | import Text.XmlHtml 41 | 42 | #if !MIN_VERSION_base(4,8,0) 43 | import Data.Word (Word) 44 | #endif 45 | 46 | ------------------------------------------------------------------------------ 47 | import qualified Heist.Compiled.Internal as C 48 | import Heist.Interpreted.Internal 49 | import Heist.Internal.Types.HeistState 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | cacheTagName :: Text 54 | cacheTagName = "cache" 55 | 56 | 57 | ------------------------------------------------------------------------------ 58 | -- | State for storing cache tag information 59 | newtype CacheTagState = 60 | CTS (MVar ([IORef (Maybe (UTCTime, Builder))], HashMap Text (UTCTime, Template))) 61 | 62 | 63 | addCompiledRef :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO () 64 | addCompiledRef ref (CTS mv) = do 65 | modifyMVar_ mv (\(a,b) -> return (ref:a, b)) 66 | 67 | 68 | ------------------------------------------------------------------------------ 69 | -- | Clears the cache tag state. 70 | clearCacheTagState :: CacheTagState -> IO () 71 | clearCacheTagState (CTS cacheMVar) = do 72 | refs <- modifyMVar cacheMVar (\(a,_) -> return ((a, H.empty), a)) 73 | mapM_ (\ref -> writeIORef ref Nothing) refs 74 | 75 | 76 | ------------------------------------------------------------------------------ 77 | -- | Converts a TTL string into an integer number of seconds. 78 | parseTTL :: Text -> Int 79 | parseTTL s = value * multiplier 80 | where 81 | (value,rest) = either (const (0::Int,"s")) id $ decimal s 82 | multiplier = case T.take 1 rest of 83 | "s" -> 1 :: Int 84 | "m" -> 60 85 | "h" -> 3600 86 | "d" -> 86400 87 | "w" -> 604800 88 | _ -> 1 89 | 90 | 91 | getTTL :: Node -> NominalDiffTime 92 | getTTL tree = fromIntegral $ maybe 0 parseTTL $ getAttribute "ttl" tree 93 | {-# INLINE getTTL #-} 94 | 95 | 96 | ------------------------------------------------------------------------------ 97 | -- | This is the splice that actually does the work. You should bind it to 98 | -- the same tag name as you bound the splice returned by mkCacheTag otherwise 99 | -- it won't work and you'll get runtime errors. 100 | cacheImpl :: (MonadIO n) => CacheTagState -> Splice n 101 | cacheImpl (CTS mv) = do 102 | tree <- getParamNode 103 | let err = error $ unwords ["cacheImpl is bound to a tag" 104 | ,"that didn't get an id attribute." 105 | ," This should never happen."] 106 | let i = maybe err id $ getAttribute "id" tree 107 | !ttl = getTTL tree 108 | mp <- liftIO $ readMVar mv 109 | 110 | ns <- do 111 | cur <- liftIO getCurrentTime 112 | let mbn = H.lookup i $ snd mp 113 | reload = do 114 | nodes' <- runNodeList $ childNodes tree 115 | let newMap = H.insert i (cur, nodes') $ snd mp 116 | liftIO $ modifyMVar_ mv (\(a,_) -> return (a, newMap)) 117 | return $! nodes' 118 | case mbn of 119 | Nothing -> reload 120 | (Just (lastUpdate,n)) -> do 121 | if ttl > 0 && tagName tree == Just cacheTagName && 122 | diffUTCTime cur lastUpdate > ttl 123 | then reload 124 | else do 125 | stopRecursion 126 | return $! n 127 | 128 | return ns 129 | 130 | 131 | ------------------------------------------------------------------------------ 132 | -- | This is the compiled splice version of cacheImpl. 133 | cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n 134 | cacheImplCompiled cts = do 135 | tree <- getParamNode 136 | let !ttl = getTTL tree 137 | 138 | compiled <- C.runNodeList $ childNodes tree 139 | ref <- liftIO $ newIORef Nothing 140 | liftIO $ addCompiledRef ref cts 141 | let reload curTime = do 142 | builder <- C.codeGen compiled 143 | let out = fromByteString $! toByteString $! builder 144 | liftIO $ writeIORef ref (Just (curTime, out)) 145 | return $! out 146 | return $ C.yieldRuntime $ do 147 | mbn <- liftIO $ readIORef ref 148 | cur <- liftIO getCurrentTime 149 | case mbn of 150 | Nothing -> reload cur 151 | (Just (lastUpdate,bs)) -> do 152 | if (ttl > 0 && diffUTCTime cur lastUpdate > ttl) 153 | then reload cur 154 | else return $! bs 155 | 156 | 157 | ------------------------------------------------------------------------------ 158 | -- | Returns items necessary to set up a \"cache\" tag. The cache tag cannot 159 | -- be bound automatically with the other default Heist tags. This is because 160 | -- this function also returns CacheTagState, so the user will be able to clear 161 | -- it with the 'clearCacheTagState' function. 162 | -- 163 | -- This function returns a splice and a CacheTagState. The splice is of type 164 | -- @Splice IO@ because it has to be bound as a load time preprocessing splice. 165 | -- Haskell's type system won't allow you to screw up and pass this splice as 166 | -- the wrong argument to initHeist. 167 | mkCacheTag :: IO (Splice IO, CacheTagState) 168 | mkCacheTag = do 169 | sr <- newIORef $ Set.empty 170 | mv <- liftM CTS $ newMVar ([], H.empty) 171 | 172 | return $ (setupSplice sr, mv) 173 | 174 | 175 | ------------------------------------------------------------------------------ 176 | -- | Explicit type signature to avoid the Show polymorphism problem. 177 | generateId :: IO Word 178 | generateId = getStdRandom random 179 | 180 | 181 | ------------------------------------------------------------------------------ 182 | -- | Gets a unique ID for use in the cache tags. 183 | getId :: IORef (Set.HashSet Text) -> IO Text 184 | getId setref = do 185 | i <- liftM (T.pack . show) generateId 186 | _set <- readIORef setref 187 | if Set.member i _set 188 | then getId setref 189 | else do 190 | writeIORef setref $ Set.insert i _set 191 | return $ T.append "cache-id-" i 192 | 193 | 194 | ------------------------------------------------------------------------------ 195 | -- | A splice that sets the id attribute so that nodes can be cache-aware. 196 | setupSplice :: IORef (Set.HashSet Text) -> Splice IO 197 | setupSplice setref = do 198 | i <- liftIO $ getId setref 199 | node <- getParamNode 200 | 201 | newChildren <- runNodeList $ childNodes node 202 | stopRecursion 203 | return $ [setAttribute "id" i $ node { elementChildren = newChildren }] 204 | 205 | 206 | -------------------------------------------------------------------------------- /src/Heist/Splices/Html.hs: -------------------------------------------------------------------------------- 1 | module Heist.Splices.Html where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Maybe 5 | import Data.Text (Text) 6 | import qualified Text.XmlHtml as X 7 | 8 | ------------------------------------------------------------------------------ 9 | import Heist.Interpreted.Internal 10 | import Heist.Internal.Types.HeistState 11 | 12 | 13 | ------------------------------------------------------------------------------ 14 | -- | Name for the html splice. 15 | htmlTag :: Text 16 | htmlTag = "html" 17 | 18 | 19 | ------------------------------------------------------------------------------ 20 | -- | The html splice runs all children and then traverses the returned node 21 | -- forest removing all head nodes. Then it merges them all and prepends it to 22 | -- the html tag's child list. 23 | htmlImpl :: Monad n => Splice n 24 | htmlImpl = do 25 | node <- getParamNode 26 | children <- runNodeList $ X.childNodes node 27 | let (heads, mnode) = extractHeads $ node { X.elementChildren = children } 28 | new (X.Element t a c) = X.Element t a $ 29 | X.Element "head" [] heads : c 30 | new n = n 31 | stopRecursion 32 | return [maybe node new mnode] 33 | 34 | ------------------------------------------------------------------------------ 35 | -- | Extracts all heads from a node tree. 36 | extractHeads :: X.Node 37 | -- ^ The root (html) node 38 | -> ([X.Node], Maybe X.Node) 39 | -- ^ A tuple of a list of head nodes and the original tree with 40 | -- heads removed. 41 | extractHeads (X.Element t a c) 42 | | t == "head" = (c, Nothing) 43 | | otherwise = (concat heads, Just $ X.Element t a (catMaybes mcs)) 44 | where 45 | (heads, mcs) = unzip $ map extractHeads c 46 | extractHeads n = ([], Just n) 47 | 48 | -------------------------------------------------------------------------------- /src/Heist/Splices/Ignore.hs: -------------------------------------------------------------------------------- 1 | module Heist.Splices.Ignore where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Data.Text (Text) 5 | 6 | ------------------------------------------------------------------------------ 7 | import Heist.Interpreted.Internal 8 | 9 | 10 | ------------------------------------------------------------------------------ 11 | -- | Default name for the ignore splice. 12 | ignoreTag :: Text 13 | ignoreTag = "ignore" 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- | The ignore tag and everything it surrounds disappears in the 18 | -- rendered output. 19 | ignoreImpl :: Monad m => Splice m 20 | ignoreImpl = return [] 21 | 22 | 23 | -------------------------------------------------------------------------------- /src/Heist/Splices/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | 7 | module Heist.Splices.Json ( 8 | bindJson 9 | ) where 10 | 11 | ------------------------------------------------------------------------------ 12 | import Control.Monad.Reader 13 | import Data.Aeson 14 | import qualified Data.ByteString.Char8 as S 15 | import qualified Data.ByteString.Lazy.Char8 as L 16 | #if MIN_VERSION_aeson(2,0,0) 17 | import qualified Data.Aeson.KeyMap as KM 18 | import qualified Data.Aeson.Key as K 19 | import qualified Data.Foldable.WithIndex as FI 20 | #else 21 | import qualified Data.HashMap.Strict as Map 22 | #endif 23 | import Data.Map.Syntax 24 | import Data.Maybe 25 | import Data.Text (Text) 26 | import qualified Data.Text as T 27 | import qualified Data.Text.Encoding as T 28 | import qualified Data.Vector as V 29 | import Text.Blaze.Html5 ((!)) 30 | import qualified Text.Blaze.Html5 as B 31 | import Text.Blaze.Renderer.XmlHtml 32 | import Text.XmlHtml 33 | ------------------------------------------------------------------------------ 34 | import Heist.Interpreted.Internal 35 | import Heist.Internal.Types.HeistState 36 | ------------------------------------------------------------------------------ 37 | 38 | ------------ 39 | -- public -- 40 | ------------ 41 | 42 | ------------------------------------------------------------------------------ 43 | -- | This splice binds convenience tags for the given JSON (or 44 | -- JSON-convertible) value and runs the tag's child nodes using the new 45 | -- bindings. 46 | -- 47 | -- /Tags bound when you pass in an object/ 48 | -- 49 | -- Tags bound for an object looking like this: 50 | -- 51 | -- > { "k_1": v_1, ..., "k_N": v_N } 52 | -- 53 | -- @\@ -- treats v_i as text 54 | -- @\@ -- treats v_i as HTML 55 | -- @\@ -- explodes v_i and runs its children 56 | -- 57 | -- @\@ -- walks the JSON tree to find 58 | -- \"foo.bar.baz\", and interprets it as a string 59 | -- @\@ 60 | -- @\...\@ 61 | -- 62 | -- /Tags bound when you pass in anything else/ 63 | -- 64 | -- @\@ -- the given JSON value, as a string 65 | -- @\@ -- the given JSON value, parsed and spliced in as HTML 66 | -- 67 | bindJson :: (ToJSON a, Monad n) => a -> Splice n 68 | bindJson = runReaderT explodeTag . toJSON 69 | 70 | 71 | ------------- 72 | -- private -- 73 | ------------- 74 | 75 | ------------------------------------------------------------------------------ 76 | errorMessage :: String -> [Node] 77 | errorMessage s = renderHtmlNodes $ 78 | B.strong ! B.customAttribute "class" "error" $ 79 | B.toHtml s 80 | 81 | 82 | ------------------------------------------------------------------------------ 83 | type JsonMonad n m a = ReaderT Value (HeistT n m) a 84 | 85 | 86 | ------------------------------------------------------------------------------ 87 | withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a 88 | withValue = flip runReaderT 89 | 90 | 91 | ------------------------------------------------------------------------------ 92 | boolToText :: Bool -> Text 93 | boolToText b = if b then "true" else "false" 94 | 95 | 96 | ------------------------------------------------------------------------------ 97 | numToText :: ToJSON a => a -> Text 98 | numToText = T.decodeUtf8 . S.concat . L.toChunks . encode 99 | 100 | ------------------------------------------------------------------------------ 101 | findExpr :: Text -> Value -> Maybe Value 102 | findExpr t = go (T.split (=='.') t) 103 | where 104 | go [] !value = Just value 105 | go (x:xs) !value = findIn value >>= go xs 106 | where 107 | #if MIN_VERSION_aeson(2,0,0) 108 | findIn (Object obj) = KM.lookup (K.fromText x) obj 109 | #else 110 | findIn (Object obj) = Map.lookup x obj 111 | #endif 112 | findIn (Array arr) = tryReadIndex >>= \i -> arr V.!? i 113 | findIn _ = Nothing 114 | 115 | tryReadIndex = fmap fst . listToMaybe . reads . T.unpack $ x 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | asHtml :: Monad m => Text -> m [Node] 120 | asHtml t = 121 | case (parseHTML "" $ T.encodeUtf8 t) of 122 | Left e -> return $ errorMessage $ 123 | "Template error turning JSON into HTML: " ++ e 124 | Right d -> return $! docContent d 125 | 126 | 127 | ------------------------------------------------------------------------------ 128 | snippetTag :: Monad m => JsonMonad n m [Node] 129 | snippetTag = ask >>= snip 130 | where 131 | txt t = lift $ asHtml t 132 | 133 | snip Null = txt "" 134 | snip (Bool b) = txt $ boolToText b 135 | snip (Number n) = txt $ numToText n 136 | snip (String t) = txt t 137 | snip _ = lift $ do 138 | node <- getParamNode 139 | return $ errorMessage $ concat [ 140 | "error processing tag <" 141 | , T.unpack $ fromMaybe "???" $ tagName node 142 | , ">: can't interpret JSON arrays or objects as HTML." 143 | ] 144 | 145 | 146 | ------------------------------------------------------------------------------ 147 | valueTag :: Monad m => JsonMonad n m [Node] 148 | valueTag = ask >>= go 149 | where 150 | go Null = txt "" 151 | go (Bool b) = txt $ boolToText b 152 | go (Number n) = txt $ numToText n 153 | go (String t) = txt t 154 | go _ = lift $ do 155 | node <- getParamNode 156 | return $ errorMessage $ concat [ 157 | "error processing tag <" 158 | , T.unpack $ fromMaybe "???" $ tagName node 159 | , ">: can't interpret JSON arrays or objects as text." 160 | ] 161 | 162 | 163 | txt t = return [TextNode t] 164 | 165 | 166 | ------------------------------------------------------------------------------ 167 | explodeTag :: forall n. (Monad n) => JsonMonad n n [Node] 168 | explodeTag = ask >>= go 169 | where 170 | -------------------------------------------------------------------------- 171 | go Null = goText "" 172 | go (Bool b) = goText $ boolToText b 173 | go (Number n) = goText $ numToText n 174 | go (String t) = goText t 175 | go (Array a) = goArray a 176 | go (Object o) = goObject o 177 | 178 | -------------------------------------------------------------------------- 179 | goText t = lift $ runChildrenWith $ do 180 | "value" ## return [TextNode t] 181 | "snippet" ## asHtml t 182 | 183 | -------------------------------------------------------------------------- 184 | goArray :: V.Vector Value -> JsonMonad n n [Node] 185 | goArray a = do 186 | lift stopRecursion 187 | dl <- V.foldM f id a 188 | return $! dl [] 189 | where 190 | f dl jsonValue = do 191 | tags <- go jsonValue 192 | return $! dl . (tags ++) 193 | 194 | -------------------------------------------------------------------------- 195 | -- search the param node for attribute \"var=expr\", search the given JSON 196 | -- object for the expression, and if it's found run the JsonMonad action m 197 | -- using the restricted JSON object. 198 | varAttrTag :: Value -> (JsonMonad n n [Node]) -> Splice n 199 | varAttrTag v m = do 200 | node <- getParamNode 201 | maybe (noVar node) (hasVar node) $ getAttribute "var" node 202 | where 203 | noVar node = return $ errorMessage $ 204 | concat [ "expression error: no var attribute in <" 205 | , T.unpack $ fromMaybe "???" $ tagName node 206 | , "> tag" 207 | ] 208 | 209 | hasVar node expr = maybe (return $ errorMessage $ 210 | concat [ 211 | "expression error: can't find \"" 212 | , T.unpack expr 213 | , "\" in JSON object (<" 214 | , T.unpack $ fromMaybe "???" $ tagName node 215 | , "> tag)" 216 | ]) 217 | (runReaderT m) 218 | (findExpr expr v) 219 | 220 | -------------------------------------------------------------------------- 221 | genericBindings :: JsonMonad n n (Splices (Splice n)) 222 | genericBindings = ask >>= \v -> return $ do 223 | "with" ## varAttrTag v explodeTag 224 | "snippet" ## varAttrTag v snippetTag 225 | "value" ## varAttrTag v valueTag 226 | 227 | 228 | -------------------------------------------------------------------------- 229 | goObject obj = do 230 | start <- genericBindings 231 | #if MIN_VERSION_aeson(2,0,0) 232 | let bindings = FI.ifoldl' (flip bindKvp) start obj 233 | #else 234 | let bindings = Map.foldlWithKey' bindKvp start obj 235 | #endif 236 | lift $ runChildrenWith bindings 237 | 238 | -------------------------------------------------------------------------- 239 | 240 | bindKvp bindings k v = 241 | #if MIN_VERSION_aeson(2,0,0) 242 | let k' = K.toText k 243 | #else 244 | let k' = k 245 | #endif 246 | newBindings = do 247 | T.append "with:" k' ## withValue v explodeTag 248 | T.append "snippet:" k' ## withValue v snippetTag 249 | T.append "value:" k' ## withValue v valueTag 250 | in bindings >> newBindings -------------------------------------------------------------------------------- /src/Heist/Splices/Markdown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-| The \"markdown\" splice formats markdown content as HTML and inserts 5 | it into the document. 6 | 7 | If the file attribute is present the contents of the tag is ignored and 8 | the file specified is converted to HTML. 9 | 10 | Otherwise the non-markup children of the tag are processed as markdown 11 | and converted to HTML. 12 | 13 | This splice requires that the \"pandoc\" executable is in your path. 14 | 15 | You can add custom pandoc splice with 'pandocSplice'. It is not limited to 16 | markdown input, and can process anything pandoc can. 17 | 18 | For example you can create a page with generated table of contents, using 19 | heist template as pandoc template. 20 | 21 | > 22 | > 23 | > <pageTitle/> 24 | > 25 | >
26 | > 27 | > 28 | 29 | And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and 30 | applies "_wrap" template. 31 | 32 | > 33 | > 34 | > $title$ 35 | > $toc$ 36 | > $body$ 37 | > 38 | 39 | Bind splice pandoc splice. Set it to not wrap in div, or it will break html 40 | from _wrap.tpl 41 | 42 | > splices = "docmarkdown" ## pandocSplice opts 43 | > where 44 | > opts = setPandocArgs ["-S", "--no-wrap", "--toc" 45 | > , "--standalone" 46 | > , "--template", "_pandoc.tpl" 47 | > , "--html5"] 48 | > $ setPandocWrapDiv Nothing 49 | > $ defaultPandocOptions 50 | > 51 | 52 | And then use it to render your markdown file 53 | 54 | 55 | > 56 | > 57 | > 58 | > 59 | > 60 | > 61 | > 62 | > 63 | > 64 | > 65 | 66 | -} 67 | module Heist.Splices.Markdown 68 | ( 69 | -- * Exceptions 70 | PandocMissingException 71 | , MarkdownException 72 | , NoMarkdownFileException 73 | -- * Markdown Splice 74 | , markdownTag 75 | , markdownSplice 76 | -- * Generic pandoc splice 77 | , pandocSplice 78 | -- ** Pandoc Options 79 | , PandocOptions 80 | , defaultPandocOptions 81 | , setPandocExecutable 82 | , setPandocArgs 83 | , setPandocBaseDir 84 | , setPandocWrapDiv 85 | -- ** Lens for 'PandocOptions' 86 | , pandocExecutable 87 | , pandocArgs 88 | , pandocBaseDir 89 | , pandocWrapDiv 90 | ) where 91 | 92 | ------------------------------------------------------------------------------ 93 | import Control.Concurrent 94 | import Control.Exception.Lifted 95 | import Control.Monad 96 | import Control.Monad.Trans 97 | import Data.ByteString (ByteString) 98 | import qualified Data.ByteString as B 99 | import qualified Data.ByteString.Char8 as BC 100 | import Data.Maybe (fromMaybe) 101 | import Data.Text (Text) 102 | import qualified Data.Text as T 103 | import qualified Data.Text.Encoding as T 104 | import Data.Typeable 105 | import System.Directory 106 | import System.Exit 107 | import System.FilePath.Posix 108 | import System.IO 109 | import System.Process 110 | import Text.XmlHtml 111 | 112 | #if !MIN_VERSION_base(4,8,0) 113 | import Control.Applicative ((<$>)) 114 | #endif 115 | 116 | ------------------------------------------------------------------------------ 117 | import Heist.Common 118 | import Heist.Internal.Types.HeistState 119 | import Heist.Interpreted.Internal 120 | 121 | data PandocMissingException = PandocMissingException 122 | deriving (Typeable) 123 | 124 | instance Show PandocMissingException where 125 | show PandocMissingException = 126 | "Cannot find the \"pandoc\" executable. If you have Haskell, then install it with \"cabal install\". Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html. Then make sure it is in your $PATH." 127 | 128 | instance Exception PandocMissingException 129 | 130 | 131 | data MarkdownException = MarkdownException ByteString 132 | deriving (Typeable) 133 | 134 | instance Show MarkdownException where 135 | show (MarkdownException e) = 136 | "Markdown error: pandoc replied:\n\n" ++ BC.unpack e 137 | 138 | instance Exception MarkdownException 139 | 140 | 141 | data NoMarkdownFileException = NoMarkdownFileException 142 | deriving (Typeable) 143 | 144 | instance Show NoMarkdownFileException where 145 | show NoMarkdownFileException = 146 | "Markdown error: no file or template in context" ++ 147 | " during processing of markdown tag" 148 | 149 | instance Exception NoMarkdownFileException where 150 | 151 | -------------------------------------------------------------------------------- 152 | 153 | data PandocOptions = PandocOptions 154 | { _pandocExecutable :: FilePath 155 | , _pandocArgs :: [String] -- ^ Arguments to pandoc 156 | , _pandocBaseDir :: Maybe FilePath -- ^ Base directory for input files 157 | -- defaults to template path 158 | , _pandocWrapDiv :: Maybe Text -- ^ Wrap content in div with class 159 | } deriving (Eq, Ord, Show) 160 | 161 | -- | Default options 162 | defaultPandocOptions :: PandocOptions 163 | defaultPandocOptions = PandocOptions "pandoc" 164 | [] 165 | Nothing 166 | (Just "markdown") 167 | 168 | -- | Name of pandoc executable 169 | setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions 170 | setPandocExecutable e opt = opt { _pandocExecutable = e } 171 | 172 | -- | Arguments passed to pandoc 173 | setPandocArgs :: [String] -> PandocOptions -> PandocOptions 174 | setPandocArgs args opt = opt { _pandocArgs = args } 175 | 176 | -- | Base directory for input files, defaults to current template dir 177 | setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions 178 | setPandocBaseDir bd opt = opt { _pandocBaseDir = bd } 179 | 180 | -- | Wrap pandoc output in div with class. Appends node attributes to 181 | -- div and appends class to ones specified on node. 182 | setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions 183 | setPandocWrapDiv wd opt = opt { _pandocWrapDiv = wd } 184 | 185 | pandocExecutable :: Functor f => 186 | (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions 187 | pandocExecutable f po = (\e -> po { _pandocExecutable = e}) 188 | <$> f (_pandocExecutable po) 189 | 190 | pandocArgs :: Functor f => 191 | ([String] -> f [String]) -> PandocOptions -> f PandocOptions 192 | pandocArgs f po = (\a -> po { _pandocArgs = a}) <$> f (_pandocArgs po) 193 | 194 | pandocBaseDir :: Functor f => 195 | (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions 196 | pandocBaseDir f po = (\b -> po {_pandocBaseDir = b }) <$> f (_pandocBaseDir po) 197 | 198 | pandocWrapDiv :: Functor f => 199 | (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions 200 | pandocWrapDiv f po = (\w -> po {_pandocWrapDiv = w}) <$> f (_pandocWrapDiv po) 201 | 202 | ------------------------------------------------------------------------------ 203 | -- | Default name for the markdown splice. 204 | markdownTag :: Text 205 | markdownTag = "markdown" 206 | 207 | ------------------------------------------------------------------------------ 208 | -- | Default markdown splice with executable "pandoc" 209 | markdownSplice :: MonadIO m => Splice m 210 | markdownSplice= pandocSplice defaultPandocOptions 211 | 212 | -- | Implementation of the markdown splice. 213 | pandocSplice :: MonadIO m => PandocOptions -> Splice m 214 | pandocSplice PandocOptions{..} = do 215 | templateDir <- liftM (fmap takeDirectory) getTemplateFilePath 216 | pdMD <- liftIO $ findExecutable _pandocExecutable 217 | 218 | pandocExe <- case pdMD of 219 | Nothing -> liftIO $ throwIO PandocMissingException 220 | Just pd -> return pd 221 | let withDir tp = fromMaybe tp _pandocBaseDir 222 | pandocFile f tp = pandocWith pandocExe _pandocArgs (withDir tp) f 223 | tree <- getParamNode 224 | (source,markup) <- liftIO $ 225 | case getAttribute "file" tree of 226 | Just f -> do 227 | m <- maybe (liftIO $ throwIO NoMarkdownFileException ) 228 | (pandocFile (T.unpack f)) 229 | templateDir 230 | return (T.unpack f,m) 231 | Nothing -> do 232 | m <- pandocWithBS pandocExe _pandocArgs $ T.encodeUtf8 $ nodeText tree 233 | return ("inline_splice",m) 234 | 235 | let ee = parseHTML source markup 236 | nodeAttrs = case tree of 237 | Element _ a _ -> a 238 | _ -> [] 239 | nodeClass = lookup "class" nodeAttrs 240 | attrs = filter (\(name, _) -> name /= "class" && name /= "file") nodeAttrs 241 | case ee of 242 | Left e -> throw $ MarkdownException 243 | $ BC.pack ("Error parsing markdown output: " ++ e) 244 | Right d -> return $ wrapResult nodeClass attrs (docContent d) 245 | 246 | where 247 | wrapResult nodeClass attrs body = case _pandocWrapDiv of 248 | Nothing -> body 249 | Just cls -> let finalAttrs = ("class", appendClass nodeClass cls):attrs 250 | in [Element "div" finalAttrs body] 251 | appendClass Nothing cls = cls 252 | appendClass (Just orig) cls = T.concat [orig, " ", cls] 253 | 254 | 255 | pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString 256 | pandocWith path args templateDir inputFile = do 257 | (ex, sout, serr) <- readProcessWithExitCode' path args' "" 258 | 259 | when (isFail ex) $ throw $ MarkdownException serr 260 | return sout 261 | 262 | where 263 | isFail ExitSuccess = False 264 | isFail _ = True 265 | 266 | args' = args ++ [templateDir inputFile ] 267 | 268 | pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString 269 | pandocWithBS pandocPath args s = do 270 | -- using the crummy string functions for convenience here 271 | (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s 272 | 273 | when (isFail ex) $ throw $ MarkdownException serr 274 | return sout 275 | 276 | where 277 | isFail ExitSuccess = False 278 | isFail _ = True 279 | 280 | 281 | -- a version of readProcessWithExitCode that does I/O properly 282 | readProcessWithExitCode' 283 | :: FilePath -- ^ command to run 284 | -> [String] -- ^ any arguments 285 | -> ByteString -- ^ standard input 286 | -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr 287 | readProcessWithExitCode' cmd args input = do 288 | (Just inh, Just outh, Just errh, pid) <- 289 | createProcess (proc cmd args){ std_in = CreatePipe, 290 | std_out = CreatePipe, 291 | std_err = CreatePipe } 292 | outMVar <- newEmptyMVar 293 | 294 | outM <- newEmptyMVar 295 | errM <- newEmptyMVar 296 | 297 | -- fork off a thread to start consuming stdout 298 | _ <- forkIO $ do 299 | out <- B.hGetContents outh 300 | putMVar outM out 301 | putMVar outMVar () 302 | 303 | -- fork off a thread to start consuming stderr 304 | _ <- forkIO $ do 305 | err <- B.hGetContents errh 306 | putMVar errM err 307 | putMVar outMVar () 308 | 309 | -- now write and flush any input 310 | when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh 311 | hClose inh -- done with stdin 312 | 313 | -- wait on the output 314 | takeMVar outMVar 315 | takeMVar outMVar 316 | hClose outh 317 | 318 | -- wait on the process 319 | ex <- waitForProcess pid 320 | 321 | out <- readMVar outM 322 | err <- readMVar errM 323 | 324 | return (ex, out, err) 325 | -------------------------------------------------------------------------------- /src/Heist/TemplateDirectory.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This module defines a TemplateDirectory data structure for convenient 4 | interaction with templates within web apps. 5 | 6 | -} 7 | 8 | module Heist.TemplateDirectory 9 | ( TemplateDirectory 10 | , newTemplateDirectory 11 | , newTemplateDirectory' 12 | 13 | , getDirectoryHS 14 | , getDirectoryCTS 15 | , reloadTemplateDirectory 16 | ) where 17 | 18 | ------------------------------------------------------------------------------ 19 | import Control.Concurrent 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Heist 23 | import Heist.Internal.Types 24 | import Heist.Splices.Cache 25 | 26 | 27 | ------------------------------------------------------------------------------ 28 | -- | Structure representing a template directory. 29 | data TemplateDirectory n 30 | = TemplateDirectory 31 | FilePath 32 | (HeistConfig n) 33 | (MVar (HeistState n)) 34 | (MVar CacheTagState) 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | -- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for 39 | -- error handling. 40 | newTemplateDirectory 41 | :: MonadIO n 42 | => FilePath 43 | -> HeistConfig n 44 | -- namespaced tag. 45 | -> IO (Either [String] (TemplateDirectory n)) 46 | newTemplateDirectory dir hc = do 47 | let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates dir] } 48 | let hc' = hc { _hcSpliceConfig = sc } 49 | epair <- initHeistWithCacheTag hc' 50 | case epair of 51 | Left es -> return $ Left es 52 | Right (hs,cts) -> do 53 | tsMVar <- liftIO $ newMVar hs 54 | ctsMVar <- liftIO $ newMVar cts 55 | return $ Right $ TemplateDirectory dir hc' tsMVar ctsMVar 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -- | Creates and returns a new 'TemplateDirectory', using the monad's fail 60 | -- function on error. 61 | newTemplateDirectory' 62 | :: MonadIO n 63 | => FilePath 64 | -> HeistConfig n 65 | -> IO (TemplateDirectory n) 66 | newTemplateDirectory' dir hc = do 67 | res <- newTemplateDirectory dir hc 68 | either (error . concat) return res 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- | Gets the 'HeistState' from a TemplateDirectory. 73 | getDirectoryHS :: (MonadIO n) 74 | => TemplateDirectory n 75 | -> IO (HeistState n) 76 | getDirectoryHS (TemplateDirectory _ _ tsMVar _) = 77 | liftIO $ readMVar $ tsMVar 78 | 79 | 80 | ------------------------------------------------------------------------------ 81 | -- | Clears the TemplateDirectory's cache tag state. 82 | getDirectoryCTS :: TemplateDirectory n -> IO CacheTagState 83 | getDirectoryCTS (TemplateDirectory _ _ _ ctsMVar) = readMVar ctsMVar 84 | 85 | 86 | ------------------------------------------------------------------------------ 87 | -- | Clears cached content and reloads templates from disk. 88 | reloadTemplateDirectory :: (MonadIO n) 89 | => TemplateDirectory n 90 | -> IO (Either String ()) 91 | reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do 92 | let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates p] } 93 | ehs <- initHeistWithCacheTag (hc { _hcSpliceConfig = sc }) 94 | leftPass ehs $ \(hs,cts) -> do 95 | modifyMVar_ tsMVar (const $ return hs) 96 | modifyMVar_ ctsMVar (const $ return cts) 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- | Prepends an error onto a Left. 101 | leftPass :: Monad m => Either [String] b -> (b -> m c) -> m (Either String c) 102 | leftPass e m = either (return . Left . loadError . concat) 103 | (liftM Right . m) e 104 | where 105 | loadError = (++) ("Error loading templates: " :: String) 106 | -------------------------------------------------------------------------------- /test/runTestsAndCoverage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | SUITE=./dist/build/testsuite/testsuite 6 | 7 | rm -f testsuite.tix 8 | 9 | if [ ! -f $SUITE ]; then 10 | cat </dev/null 2>&1 42 | 43 | rm -f testsuite.tix 44 | 45 | cat < String -> IO () 63 | applyComparison dir pageStr = do 64 | let page = encodeUtf8 $ T.pack pageStr 65 | hs <- loadWithCache dir 66 | let compiledAction = do 67 | res <- fst $ fromJust $ C.renderTemplate hs page 68 | return $! toByteString $! res 69 | out <- compiledAction 70 | B.writeFile (pageStr++".out.compiled."++dir) $ out 71 | 72 | let interpretedAction = do 73 | res <- I.renderTemplate hs page 74 | return $! toByteString $! fst $! fromJust res 75 | out2 <- interpretedAction 76 | B.writeFile (pageStr++".out.interpreted."++dir) $ out 77 | 78 | defaultMain 79 | [ bench (pageStr++"-compiled") (whnfIO compiledAction) 80 | , bench (pageStr++"-interpreted") (whnfIO interpretedAction) 81 | ] 82 | 83 | cmdLineTemplate :: String -> String -> IO () 84 | cmdLineTemplate dir page = do 85 | -- args <- getArgs 86 | -- let page = head args 87 | -- let dir = "test/snap-website" 88 | hs <- loadHS dir 89 | let action = fst $ fromJust $ C.renderTemplate hs 90 | (encodeUtf8 $ T.pack page) 91 | out <- action 92 | B.writeFile (page++".out.cur") $ toByteString out 93 | 94 | -- reference <- B.readFile "faq.out" 95 | -- if False 96 | -- then do 97 | -- putStrLn "Template didn't render properly" 98 | -- error "Aborting" 99 | -- else 100 | -- putStrLn "Template rendered correctly" 101 | 102 | defaultMain [ 103 | bench (page++"-speed") (whnfIO action) 104 | ] 105 | 106 | 107 | testNode = 108 | X.Element "div" [("foo", "aoeu"), ("bar", "euid")] 109 | [X.Element "b" [] [X.TextNode "bolded text"] 110 | ,X.TextNode " not bolded" 111 | ,X.Element "a" [("href", "/path/to/page")] [X.TextNode "link"] 112 | ] 113 | 114 | getChunks templateName = do 115 | hs <- loadHS "snap-website-nocache" 116 | let (Just t) = lookupTemplate templateName hs _compiledTemplateMap 117 | return $! fst $! fst t 118 | 119 | -------------------------------------------------------------------------------- /test/suite/Heist/Compiled/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Heist.Compiled.Tests where 5 | 6 | import Blaze.ByteString.Builder 7 | import Control.Applicative 8 | import Control.Exception 9 | import Control.Monad.Trans.Except 10 | import Control.Lens 11 | import Control.Monad.Trans 12 | import Data.Bifunctor (first) 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString as B 15 | import Data.Char 16 | import Data.IORef 17 | import Data.Maybe 18 | import Data.Map.Syntax 19 | import Data.Monoid 20 | import qualified Data.Set as Set 21 | import qualified Data.Text as T 22 | import Data.Text.Encoding 23 | import Test.Framework (Test) 24 | import Test.Framework.Providers.HUnit 25 | import qualified Test.HUnit as H 26 | import qualified Text.XmlHtml as X 27 | 28 | 29 | ------------------------------------------------------------------------------ 30 | import Heist 31 | import Heist.Compiled 32 | import Heist.Compiled.Internal 33 | import Heist.Internal.Types 34 | import Heist.Tutorial.CompiledSplices 35 | import Heist.TestCommon 36 | 37 | -- NOTE: We can't test compiled templates on the templates directory as it 38 | -- stands today because that directory contains some error conditions such as 39 | -- infinite bind loops, apply tags with no template attribute, and apply tags 40 | -- with ".." in the tag path (which doesn't currently work). 41 | 42 | tests :: [Test] 43 | tests = [ testCase "compiled/simple" simpleCompiledTest 44 | , testCase "compiled/people" peopleTest 45 | , testCase "compiled/namespace1" namespaceTest1 46 | , testCase "compiled/namespace2" namespaceTest2 47 | , testCase "compiled/namespace3" namespaceTest3 48 | , testCase "compiled/namespace4" namespaceTest4 49 | , testCase "compiled/namespace5" namespaceTest5 50 | , testCase "compiled/no-ns-splices" noNsSplices 51 | , testCase "compiled/ns-nested" nsNestedUnused 52 | , testCase "compiled/nsbind" nsBindTest 53 | , testCase "compiled/nsbinderr" nsBindErrorTest 54 | , testCase "compiled/nscall" nsCallTest 55 | , testCase "compiled/nscallerr" nsCallErrTest 56 | , testCase "compiled/nsbindstack" nsBindStackTest 57 | , testCase "compiled/doctype" doctypeTest 58 | , testCase "compiled/exceptions" exceptionsTest 59 | , testCase "compiled/defer" deferTest 60 | ] 61 | 62 | simpleCompiledTest :: IO () 63 | simpleCompiledTest = do 64 | res <- runWithStateSplice "templates" 65 | H.assertEqual "compiled state splice" expected res 66 | where 67 | expected = 68 | mappend doctype "\n\n\n3\n\n" 69 | 70 | peopleTest :: IO () 71 | peopleTest = do 72 | res <- personListTest "templates" 73 | H.assertEqual "people splice" expected res 74 | where 75 | expected = 76 | "\n

Doe, John: 42 years old

\n\n

Smith, Jane: 21 years old

\n\n" 77 | 78 | templateHC :: HeistConfig IO 79 | templateHC = HeistConfig sc "" False 80 | where 81 | sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 82 | & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu")) 83 | & scTemplateLocations .~ [loadTemplates "templates"] 84 | 85 | genericTest :: String -> ByteString -> ByteString -> IO () 86 | genericTest nm template expected = do 87 | res <- runExceptT $ do 88 | hs <- ExceptT $ initHeist templateHC 89 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 90 | renderTemplate hs template 91 | b <- lift $ fst runner 92 | return $ toByteString b 93 | 94 | H.assertEqual nm (Right expected) res 95 | 96 | doctypeTest :: IO () 97 | doctypeTest = genericTest "doctype test" "rss" expected 98 | where 99 | expected = encodeUtf8 100 | "http://www.devalot.com/\n" 101 | 102 | namespaceTest1 :: IO () 103 | namespaceTest1 = do 104 | res <- runExceptT $ do 105 | hs <- ExceptT $ initHeist templateHC 106 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 107 | renderTemplate hs "namespaces" 108 | b <- lift $ fst runner 109 | return $ toByteString b 110 | 111 | H.assertEqual "namespace test 1" (Right expected) res 112 | where 113 | expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n" 114 | 115 | 116 | namespaceTest2 :: IO () 117 | namespaceTest2 = do 118 | res <- runExceptT $ do 119 | hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True 120 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 121 | renderTemplate hs "namespaces" 122 | b <- lift $ fst runner 123 | return $ toByteString b 124 | 125 | H.assertEqual "namespace test 2" (Right expected) res 126 | where 127 | expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n" 128 | 129 | 130 | namespaceTest3 :: IO () 131 | namespaceTest3 = do 132 | res <- runExceptT $ do 133 | hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" 134 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 135 | renderTemplate hs "namespaces" 136 | b <- lift $ fst runner 137 | return $ toByteString b 138 | 139 | H.assertEqual "namespace test 3" (Right expected) res 140 | where 141 | expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n" 142 | 143 | 144 | namespaceTest4 :: IO () 145 | namespaceTest4 = do 146 | res <- runExceptT $ do 147 | hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" 148 | & hcErrorNotBound .~ True 149 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 150 | renderTemplate hs "namespaces" 151 | b <- lift $ fst runner 152 | return $ toByteString b 153 | 154 | H.assertEqual "namespace test 4" (Right expected) res 155 | where 156 | expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n" 157 | 158 | 159 | namespaceTest5 :: IO () 160 | namespaceTest5 = do 161 | res <- runExceptT $ do 162 | hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" 163 | & hcCompiledSplices .~ mempty 164 | & hcErrorNotBound .~ True 165 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 166 | renderTemplate hs "namespaces" 167 | b <- lift $ fst runner 168 | return $ toByteString b 169 | 170 | H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res 171 | 172 | ------------------------------------------------------------------------------ 173 | -- | The templates-no-ns directory should have no tags beginning with h: so 174 | -- this test will throw an error. 175 | noNsSplices :: IO () 176 | noNsSplices = do 177 | res <- runExceptT $ do 178 | hs <- ExceptT $ initHeist hc 179 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 180 | renderTemplate hs "test" 181 | b <- lift $ fst runner 182 | return $ toByteString b 183 | 184 | H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res 185 | where 186 | hc = HeistConfig sc "h" True 187 | sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 188 | & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu")) 189 | & scTemplateLocations .~ [loadTemplates "templates-no-ns"] 190 | 191 | 192 | ------------------------------------------------------------------------------ 193 | -- | Test that no namespace splice message works correctly when there are no 194 | -- top level splices used 195 | nsNestedUnused :: IO () 196 | nsNestedUnused = do 197 | res <- runExceptT $ do 198 | hs <- ExceptT $ initHeist hc 199 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 200 | renderTemplate hs "test" 201 | b <- lift $ fst runner 202 | return $ toByteString b 203 | 204 | H.assertEqual "ns nested unused warn test" (Right "
aeou
\n") res 205 | where 206 | hc = HeistConfig sc "h" False 207 | sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou") 208 | & scTemplateLocations .~ [loadTemplates "templates-ns-nested"] 209 | 210 | 211 | nsBindTemplateHC :: String -> HeistConfig IO 212 | nsBindTemplateHC dir = HeistConfig sc "h" False 213 | where 214 | sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 215 | & scCompiledSplices .~ nsBindTestSplices 216 | & scTemplateLocations .~ [loadTemplates dir] 217 | 218 | 219 | nsBindTestSplices :: Splices (Splice IO) 220 | nsBindTestSplices = do 221 | "call" ## do 222 | tpl <- withSplices (callTemplate "_call") 223 | nsBindSubSplices (return ()) 224 | return $ yieldRuntime $ codeGen tpl 225 | "main" ## nsBindSubImpl (return ()) 226 | "main2" ## nsBindSubImpl (return ()) 227 | 228 | 229 | nsBindSubImpl :: RuntimeSplice IO b -> Splice IO 230 | nsBindSubImpl _ = do 231 | tpl <- withSplices runChildren nsBindSubSplices (return ()) 232 | return $ yieldRuntime $ codeGen tpl 233 | 234 | 235 | nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO) 236 | nsBindSubSplices = do 237 | "sub" ## pureSplice . textSplice $ const "asdf" 238 | "recurse" ## nsBindSubImpl 239 | 240 | 241 | nsBindTest :: IO () 242 | nsBindTest = do 243 | res <- runExceptT $ do 244 | hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind") 245 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 246 | renderTemplate hs "nsbind" 247 | b <- lift $ fst runner 248 | return $ toByteString b 249 | 250 | H.assertEqual "namespace bind test" (Right expected) res 251 | where 252 | expected = "Alpha\n\nBeta\nasdf\nGamma\n\n\n" 253 | 254 | 255 | ------------------------------------------------------------------------------ 256 | -- | Test splice error reporting. 257 | nsBindErrorTest :: IO () 258 | nsBindErrorTest = do 259 | res <- runExceptT $ do 260 | hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind") 261 | & hcErrorNotBound .~ True 262 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 263 | renderTemplate hs "nsbinderror" 264 | b <- lift $ fst runner 265 | return $ toByteString b 266 | 267 | H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ]) res 268 | where 269 | err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}" 270 | err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n ... via templates-nsbind/nsbinderror.tpl: h:recurse\n ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}" 271 | err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}" 272 | 273 | 274 | ------------------------------------------------------------------------------ 275 | -- | Test splice error data structure. 276 | nsBindStackTest :: IO () 277 | nsBindStackTest = do 278 | res <- initHeist (nsBindTemplateHC "templates-nsbind") >>= 279 | return . (either Left (Right . _spliceErrors)) 280 | 281 | H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res 282 | where 283 | err1 = SpliceError [ ( ["nsbinderror"] 284 | , Just "templates-nsbind/nsbinderror.tpl" 285 | , "h:main2") ] 286 | (Just "templates-nsbind/nsbinderror.tpl") 287 | ["h:call","h:main","h:main2","h:recurse","h:sub"] 288 | (X.Element "h:invalid3" [] []) 289 | "No splice bound for h:invalid3" 290 | err2 = SpliceError [ ( ["nsbinderror"] 291 | , Just "templates-nsbind/nsbinderror.tpl" 292 | , "h:recurse") 293 | , ( ["nsbinderror"] 294 | , Just "templates-nsbind/nsbinderror.tpl" 295 | ,"h:main") ] 296 | (Just "templates-nsbind/nsbinderror.tpl") 297 | ["h:call","h:main","h:main2","h:recurse","h:sub"] 298 | (X.Element "h:invalid2" [] []) 299 | "No splice bound for h:invalid2" 300 | err3 = SpliceError [] 301 | (Just "templates-nsbind/nsbinderror.tpl") 302 | ["h:call","h:main","h:main2"] 303 | (X.Element "h:invalid1" [] []) 304 | "No splice bound for h:invalid1" 305 | 306 | 307 | nsCallTest :: IO () 308 | nsCallTest = do 309 | res <- runExceptT $ do 310 | hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall") 311 | & hcErrorNotBound .~ True 312 | & hcCompiledTemplateFilter .~ nsFilter 313 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 314 | renderTemplate hs "nscall" 315 | b <- lift $ fst runner 316 | return $ toByteString b 317 | 318 | H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res 319 | where 320 | nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head 321 | 322 | 323 | nsCallErrTest :: IO () 324 | nsCallErrTest = do 325 | res <- runExceptT $ do 326 | hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall") 327 | & hcErrorNotBound .~ True 328 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 329 | renderTemplate hs "nscall" 330 | b <- lift $ fst runner 331 | return $ toByteString b 332 | 333 | H.assertEqual "namespace call error test" 334 | (Left $ Set.fromList [ err1, err2 ]) 335 | (first Set.fromList res) 336 | where 337 | err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}" 338 | err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}" 339 | 340 | 341 | ------------------------------------------------------------------------------ 342 | -- | Test exception handling in template load. 343 | exceptionsTest :: IO () 344 | exceptionsTest = do 345 | res <- Control.Exception.catch 346 | (runExceptT $ do 347 | hs <- ExceptT $ initHeist hc 348 | -- The rest needed only for type inference. 349 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 350 | renderTemplate hs "" 351 | _ <- lift $ fst runner 352 | throwE ["Unexpected success"]) 353 | (\(e :: CompileException) -> return $ case lines (show e) of 354 | l:ls -> Right l 355 | _ -> Left [show e]) 356 | H.assertEqual "exceptions" (Right firstLine) res 357 | 358 | where 359 | firstLine = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse" 360 | 361 | hc = HeistConfig sc "h" True 362 | sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 363 | & scCompiledSplices .~ splices 364 | & scTemplateLocations .~ [loadTemplates "templates-loaderror"] 365 | splices = do 366 | "call1" ## callTemplate "_ok" 367 | "call2" ## callTemplate "_error" 368 | "adder" ## do 369 | value :: Int <- read . T.unpack . fromJust . 370 | X.getAttribute "value" <$> getParamNode 371 | return $ yieldPureText $ T.pack $ show $ 1 + value 372 | 373 | 374 | ------------------------------------------------------------------------------ 375 | -- | Test for defer functions to see that they correctly save the result of 376 | -- a runtime computation. 377 | deferTest :: IO () 378 | deferTest = do 379 | rs <- mapM newIORef $ replicate 5 (0 :: Int) 380 | res <- runExceptT $ do 381 | hs <- ExceptT $ initHeist $ hc rs 382 | runner <- noteT ["Error rendering"] $ hoistMaybe $ 383 | renderTemplate hs "test" 384 | b <- lift $ fst runner 385 | return $ toByteString b 386 | 387 | vs <- mapM readIORef rs 388 | H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res) 389 | where 390 | msg = "1 2\n1 1\n1 1\n\n1 1\n" 391 | hc rs = HeistConfig (sc rs) "h" True 392 | sc rs = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 393 | & scCompiledSplices .~ (splices rs) 394 | & scTemplateLocations .~ [loadTemplates "templates-defer"] 395 | splices [r1, r2, r3, r4, r5] = do 396 | "plain" ## subSplice $ addAndReturn r1 397 | "defer" ## deferMap return subSplice $ addAndReturn r2 398 | "maydefer" ## mayDeferMap (return . Just) subSplice $ addAndReturn r3 399 | "maydefer2" ## mayDeferMap (const $ return Nothing) subSplice $ 400 | addAndReturn r4 401 | "defermany" ## deferMany subSplice $ addAndReturn' r5 402 | subSplice = 403 | withSplices runChildren 404 | ("use" ## \n -> return $ yieldRuntimeText $ return . T.pack . show =<< n) 405 | addAndReturn r = liftIO $ modifyIORef r (+1) >> readIORef r 406 | addAndReturn' r = liftIO $ do 407 | modifyIORef r (+1) 408 | val <- readIORef r 409 | return [val] 410 | -------------------------------------------------------------------------------- /test/suite/Heist/TestCommon.hs: -------------------------------------------------------------------------------- 1 | module Heist.TestCommon where 2 | 3 | ------------------------------------------------------------------------------ 4 | import Blaze.ByteString.Builder 5 | import Control.Monad.Trans 6 | import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) 7 | import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) 8 | import Data.ByteString.Char8 (ByteString) 9 | import qualified Data.ByteString.Char8 as B 10 | import Data.Maybe 11 | import Data.Monoid 12 | 13 | 14 | ------------------------------------------------------------------------------ 15 | import Heist 16 | import qualified Heist.Compiled as C 17 | import Heist.Internal.Types 18 | import qualified Heist.Interpreted as I 19 | import qualified Heist.Interpreted.Internal as I 20 | import qualified Text.XmlHtml as X 21 | 22 | 23 | ------------------------------------------------------------------------------ 24 | -- | The default doctype given to templates 25 | doctype :: ByteString 26 | doctype = B.concat 27 | [ "" ] 29 | 30 | 31 | loadT :: MonadIO m 32 | => FilePath 33 | -> Splices (I.Splice m) 34 | -> Splices (I.Splice IO) 35 | -> Splices (C.Splice m) 36 | -> Splices (AttrSplice m) 37 | -> IO (Either [String] (HeistState m)) 38 | loadT baseDir a b c d = runExceptT $ do 39 | let sc = SpliceConfig (defaultInterpretedSplices `mappend` a) 40 | (defaultLoadTimeSplices `mappend` b) c d 41 | [loadTemplates baseDir] (const True) 42 | ExceptT $ initHeist $ HeistConfig sc "" False 43 | 44 | 45 | ------------------------------------------------------------------------------ 46 | loadIO :: FilePath 47 | -> Splices (I.Splice IO) 48 | -> Splices (I.Splice IO) 49 | -> Splices (C.Splice IO) 50 | -> Splices (AttrSplice IO) 51 | -> IO (Either [String] (HeistState IO)) 52 | loadIO baseDir a b c d = runExceptT $ do 53 | let sc = SpliceConfig (defaultInterpretedSplices >> a) 54 | (defaultLoadTimeSplices >> b) c d 55 | [loadTemplates baseDir] (const True) 56 | ExceptT $ initHeist $ HeistConfig sc "" False 57 | 58 | 59 | ------------------------------------------------------------------------------ 60 | loadHS :: FilePath -> IO (HeistState IO) 61 | loadHS baseDir = do 62 | etm <- runExceptT $ do 63 | let sc = SpliceConfig defaultInterpretedSplices 64 | defaultLoadTimeSplices mempty mempty 65 | [loadTemplates baseDir] (const True) 66 | ExceptT $ initHeist $ HeistConfig sc "" False 67 | either (error . concat) return etm 68 | 69 | 70 | loadEmpty :: Splices (I.Splice IO) 71 | -> Splices (I.Splice IO) 72 | -> Splices (C.Splice IO) 73 | -> Splices (AttrSplice IO) 74 | -> IO (HeistState IO) 75 | loadEmpty a b c d = do 76 | let sc = SpliceConfig (defaultInterpretedSplices `mappend` a) 77 | (defaultLoadTimeSplices `mappend` b) c d mempty 78 | (const True) 79 | res <- initHeist $ HeistConfig sc "" False 80 | either (error . concat) return res 81 | 82 | 83 | testTemplate :: FilePath -> ByteString -> IO ByteString 84 | testTemplate tdir tname = do 85 | ts <- loadHS tdir 86 | Just (resDoc, _) <- I.renderTemplate ts tname 87 | return $ toByteString resDoc 88 | 89 | 90 | testTemplateEval :: ByteString -> IO (Maybe Template) 91 | testTemplateEval tname = do 92 | ts <- loadHS "templates" 93 | md <- evalHeistT (I.evalWithDoctypes tname) (X.TextNode "") ts 94 | return $ fmap X.docContent md 95 | 96 | 97 | ------------------------------------------------------------------------------ 98 | -- | Reloads the templates from disk and renders the specified 99 | -- template. (Old convenience code.) 100 | quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) 101 | quickRender baseDir name = do 102 | ts <- loadHS baseDir 103 | res <- I.renderTemplate ts name 104 | return (fmap (toByteString . fst) res) 105 | 106 | cRender :: HeistState IO -> ByteString -> IO ByteString 107 | cRender hs name = do 108 | builder <- fst $ fromJust $ C.renderTemplate hs name 109 | return $ toByteString builder 110 | 111 | iRender :: HeistState IO -> ByteString -> IO ByteString 112 | iRender hs name = do 113 | builder <- I.renderTemplate hs name 114 | return $ toByteString $ fst $ fromJust builder 115 | 116 | 117 | ------------------------------------------------------------------------------ 118 | isLeft :: Either e a -> Bool 119 | isLeft (Left _) = True 120 | isLeft _ = False 121 | 122 | 123 | ------------------------------------------------------------------------------ 124 | noteT :: Monad m => e -> MaybeT m a -> ExceptT e m a 125 | noteT e ma = do 126 | x <- lift $ runMaybeT ma 127 | case x of 128 | Nothing -> ExceptT $ return (Left e) 129 | Just a -> ExceptT $ return (Right a) 130 | 131 | 132 | ------------------------------------------------------------------------------ 133 | hoistMaybe :: Monad m => Maybe a -> MaybeT m a 134 | hoistMaybe = MaybeT . return 135 | -------------------------------------------------------------------------------- /test/suite/Heist/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Heist.Tests 5 | ( tests 6 | ) where 7 | 8 | 9 | ------------------------------------------------------------------------------ 10 | import Blaze.ByteString.Builder 11 | import Control.Monad.State 12 | import qualified Data.ByteString.Char8 as B 13 | import Data.List 14 | import Data.Map.Syntax 15 | import Data.Maybe 16 | import Data.Monoid 17 | import qualified Data.Text as T 18 | import Test.Framework (Test) 19 | import Test.Framework.Providers.HUnit 20 | import qualified Test.HUnit as H 21 | 22 | 23 | ------------------------------------------------------------------------------ 24 | import Heist 25 | import qualified Heist.Compiled as C 26 | import Heist.Internal.Types 27 | import qualified Heist.Interpreted as I 28 | import Heist.Splices.Cache 29 | import Heist.Splices.Html 30 | import Heist.TemplateDirectory 31 | import Heist.Tutorial.AttributeSplices 32 | import Heist.Tutorial.CompiledSplices 33 | 34 | import Heist.TestCommon 35 | 36 | tests :: [Test] 37 | tests = [ testCase "loadErrors" loadErrorsTest 38 | , testCase "attrsplice/autocheck" attrSpliceTest 39 | , testCase "tdirCache" tdirCacheTest 40 | , testCase "headMerge" headMergeTest 41 | , testCase "bindApplyInteraction" bindApplyInteractionTest 42 | , testCase "backslashHandling" backslashHandlingTest 43 | ] 44 | 45 | 46 | ------------------------------------------------------------------------------ 47 | -- | Tests that load fails correctly on errors. 48 | loadErrorsTest :: H.Assertion 49 | loadErrorsTest = do 50 | ets <- loadIO "templates-bad" mempty mempty mempty mempty 51 | either (H.assertEqual "load errors test" expected . fmap (head . lines) . sort) 52 | (const $ H.assertFailure "No failure when loading templates-bad") 53 | ets 54 | where 55 | expected = sort 56 | ["templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in " 57 | ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"" 58 | ,"templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!" 59 | ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in " 60 | ] 61 | 62 | attrSpliceTest :: IO () 63 | attrSpliceTest = do 64 | ehs <- loadT "templates" mempty mempty mempty 65 | ("autocheck" ## lift . autocheckedSplice) 66 | let hs = either (error . show) id ehs 67 | runtime = fromJust $ C.renderTemplate hs "attr_splice" 68 | 69 | mres <- evalStateT (I.renderTemplate hs "attr_splice") "foo" 70 | H.assertEqual "interpreted foo" expected1 71 | (toByteString $ fst $ fromJust mres) 72 | mres2 <- evalStateT (I.renderTemplate hs "attr_splice") "bar" 73 | H.assertEqual "interpreted bar" expected2 74 | (toByteString $ fst $ fromJust mres2) 75 | 76 | builder <- evalStateT (fst runtime) "foo" 77 | H.assertEqual "compiled foo" expected3 78 | (toByteString builder) 79 | builder2 <- evalStateT (fst runtime) "bar" 80 | H.assertEqual "compiled bar" expected4 81 | (toByteString builder2) 82 | where 83 | expected1 = "\n\n" 84 | expected2 = "\n\n" 85 | expected3 = "\n\n" 86 | expected4 = "\n\n" 87 | 88 | fooSplice :: I.Splice (StateT Int IO) 89 | fooSplice = do 90 | val <- get 91 | put val 92 | I.textSplice $ T.pack $ show val 93 | 94 | tdirCacheTest :: IO () 95 | tdirCacheTest = do 96 | let rSplices = ("foosplice" ## fooSplice) 97 | dSplices = ("foosplice" ## stateSplice) 98 | sc = SpliceConfig rSplices mempty dSplices mempty mempty (const True) 99 | hc = HeistConfig sc "" False 100 | td <- newTemplateDirectory' "templates" hc 101 | 102 | [a,b,c,d] <- evalStateT (testInterpreted td) 5 103 | H.assertBool "interpreted doesn't cache" $ a == b 104 | H.assertBool "interpreted doesn't clear" $ b /= c 105 | H.assertBool "interpreted doesn't reload" $ c /= d 106 | 107 | td' <- newTemplateDirectory' "templates" hc 108 | [e,f,g,h] <- evalStateT (testCompiled td') 5 109 | H.assertBool "compiled doesn't cache" $ e == f 110 | H.assertBool "compiled doesn't clear" $ f /= g 111 | H.assertBool "compiled doesn't reload" $ g /= h 112 | where 113 | testInterpreted td = do 114 | hs <- liftIO $ getDirectoryHS td 115 | cts <- liftIO $ getDirectoryCTS td 116 | a <- I.renderTemplate hs "cache" 117 | modify (+1) 118 | b <- I.renderTemplate hs "cache" 119 | liftIO $ clearCacheTagState cts 120 | c <- I.renderTemplate hs "cache" 121 | modify (+1) 122 | _ <- liftIO $ reloadTemplateDirectory td 123 | 124 | -- The reload changes the HeistState, so we have to get it again 125 | hs' <- liftIO $ getDirectoryHS td 126 | d <- I.renderTemplate hs' "cache" 127 | return $ map (toByteString . fst . fromJust) [a,b,c,d] 128 | 129 | testCompiled td = do 130 | hs <- liftIO $ getDirectoryHS td 131 | cts <- liftIO $ getDirectoryCTS td 132 | a <- fst $ fromJust $ C.renderTemplate hs "cache" 133 | modify (+1) 134 | b <- fst $ fromJust $ C.renderTemplate hs "cache" 135 | liftIO $ clearCacheTagState cts 136 | c <- fst $ fromJust $ C.renderTemplate hs "cache" 137 | modify (+1) 138 | _ <- liftIO $ reloadTemplateDirectory td 139 | 140 | -- The reload changes the HeistState, so we have to get it again 141 | hs' <- liftIO $ getDirectoryHS td 142 | d <- fst $ fromJust $ C.renderTemplate hs' "cache" 143 | return $ map toByteString [a,b,c,d] 144 | 145 | 146 | headMergeTest :: IO () 147 | headMergeTest = do 148 | ehs <- loadT "templates" mempty (htmlTag ## htmlImpl) mempty mempty 149 | let hs = either (error . show) id ehs 150 | runtime = fromJust $ C.renderTemplate hs "head_merge/index" 151 | mres <- fst runtime 152 | H.assertEqual "assertion failed" expected 153 | (toByteString mres) 154 | where 155 | expected = B.intercalate "\n" 156 | ["\n\n" 157 | ,"\n\n" 158 | ,"\n\n\n\n
nav bar
\n\n\n" 159 | ,"
index page
\n\n\n\n\n" 160 | ] 161 | 162 | bindApplyInteractionTest :: IO () 163 | bindApplyInteractionTest = do 164 | hs <- loadHS "templates" 165 | 166 | cOut <- cRender hs "bind-apply-interaction/caller" 167 | H.assertEqual "compiled failure" cExpected cOut 168 | 169 | iOut <- iRender hs "bind-apply-interaction/caller" 170 | H.assertEqual "interpreted failure" iExpected iOut 171 | where 172 | cExpected = B.intercalate "\n" 173 | ["\nThis is a test." 174 | ,"===bind content===\nAnother test line." 175 | ,"apply content\nLast test line." 176 | ,"\n" 177 | ] 178 | iExpected = B.unlines 179 | ["\nThis is a test." 180 | ,"===bind content===" 181 | ,"Another test line." 182 | ,"apply content" 183 | ,"Last test line." 184 | ,"" 185 | ] 186 | 187 | 188 | ------------------------------------------------------------------------------ 189 | -- | Test backslash escaping in the attribute parser. 190 | backslashHandlingTest :: IO () 191 | backslashHandlingTest = do 192 | hs <- loadHS "templates" 193 | cOut <- cRender hs "backslash" 194 | H.assertEqual "compiled failure" expected cOut 195 | 196 | iOut <- iRender hs "backslash" 197 | H.assertEqual "interpreted failure" expected iOut 198 | where 199 | expected = "\n" 200 | 201 | -------------------------------------------------------------------------------- /test/suite/Heist/Tutorial/AttributeSplices.lhs: -------------------------------------------------------------------------------- 1 | Attribute Splices 2 | ================= 3 | 4 | Attribute splices are new in Heist 0.10. They solve the problem of wanting to 5 | be able to dynamically make empty attributes appear or disappear with a splice 6 | without binding a splice to the whole tag. This issue comes up most 7 | frequently when dealing with empty attributes such as HTML's "disabled" or 8 | "checked". 9 | 10 | > module Heist.Tutorial.AttributeSplices where 11 | > import Heist.Tutorial.Imports 12 | 13 | Consider a page with several radio buttons. You want the correct one to be 14 | selected based on the value of a parameter in the HTTP request. The HTML 15 | would look something like this: 16 | 17 | Red 18 | Green 19 | Blue 20 | 21 | We want to automatically generate the "checked" attribute appropriately. This 22 | could be done with a splice bound to the input tag, but there might be a 23 | number of other input tags on the page, so your splice would at best be 24 | executed on more tags than necessary and at worst not have the granularity 25 | necessary to work properly. The ${} syntax for splices inside of attribute 26 | values also won't work because it can only affect an attribute's value. It 27 | can't make the attribute disappear entirely. This problem can be solved 28 | nicely with attribute splices that have the following type: 29 | 30 | < type AttrSplice m = Text -> m [(Text, Text)] 31 | 32 | An attribute splice is a computation in the runtime monad that takes the value 33 | of the attribute it is bound to as its argument and returns a list of 34 | attributes to substitute back into the tag. Here's how we might implement a 35 | splice to solve the above problem. 36 | 37 | > autocheckedSplice :: Text -> StateT Text IO [(Text, Text)] 38 | > autocheckedSplice v = do 39 | > val <- get -- app-specific retrieval of the appropriate value here 40 | > let checked = if v == val 41 | > then [("checked","")] 42 | > else [] 43 | > return $ ("value", v) : checked 44 | 45 | In this toy example we are using `StateT Text IO` as our "runtime" monad where 46 | the Text state holds the value of the radio button that should be checked. We 47 | assume that the current value we're checking against is passed as the bound 48 | attribute's value, so we compare that against the value to be checked. Then 49 | we return a list with the appropriate value and the checked attribute if 50 | necessary. We bind this splice to the "autocheck" attribute by adding it to 51 | the hcAttributeSplices list in HeistConfig. 52 | 53 | To make everything work we use the following markup for our radio buttons: 54 | 55 | Red 56 | Green 57 | Blue 58 | 59 | -------------------------------------------------------------------------------- /test/suite/Heist/Tutorial/CompiledSplices.lhs: -------------------------------------------------------------------------------- 1 | Introduction to Compiled Heist 2 | ============================== 3 | 4 | Before version 0.10, Heist has essentially been an interpreter. It loads your 5 | templates and "runs" them whenever a page is served. This is relatively 6 | inefficient since a lot of document transformations happen every time the 7 | template is requested. For Heist version 0.10 we completely rethought 8 | everything with performance in mind. We call it "compiled Heist". The main 9 | idea is to do most of your splice processing up front at load time. There is 10 | still a mechanism for rendering dynamic information at runtime, but it is 11 | faster than the fully interpreted approach that Heist started with. 12 | 13 | It should also be mentioned that the old "interpreted Heist" is not gone. You 14 | can still use the old approach where all the transformations happen at 15 | render time. This allows you to upgrade without making sweeping changes to 16 | your code, and gradually convert your application to the more performant 17 | compiled approach as you see fit. 18 | 19 | Before we continue it should be mentioned that you are reading real live 20 | literate Haskell code from our test suite. All the code you see here is 21 | compiled into our test suite and the results automatically checked by our 22 | buildbot. So first we need to get some boilerplate and imports out of the way. 23 | 24 | > {-# LANGUAGE NoMonomorphismRestriction #-} 25 | > module Heist.Tutorial.CompiledSplices where 26 | > import Heist 27 | > import qualified Heist.Compiled as C 28 | > import Heist.Tutorial.Imports 29 | 30 | > import Control.Applicative 31 | > import Control.Lens 32 | > import Data.Map.Syntax 33 | 34 | As a review, normal (interpreted) Heist splices are defined like this. 35 | 36 | < type Splice m = HeistT m m [Node] 37 | 38 | The type parameter `m` is the runtime execution monad (in a Snap application 39 | this will usually be `Handler` or `Snap`). Don't worry about why the `m` is 40 | there twice right now. We'll get to that later. The splice's return value is 41 | a list of nodes that is substituted back into the document wherever the 42 | spliced node was. 43 | 44 | This kind of splice proccessing involves traversing the DOM, which is 45 | inefficient. Compiled Heist is designed so that all the DOM traversals happen 46 | once at load time in the IO monad. This is the "compile" phase. The type 47 | signature for compiled splices is this. 48 | 49 | < type Splice n = HeistT n IO (DList (Chunk n)) 50 | 51 | We see that where Heist splices ran in the m monad, compiled splices run in the 52 | IO monad. This also explains why HeistT now has two monad type parameters. 53 | The first parameter is a placeholder for the runtime monad and the second 54 | parameter is the monad that we're actually running in now. 55 | 56 | But the key point of the compiled splice type signature is the return value. 57 | They return a DList of Chunks. DList is a list that supports efficient 58 | insertion to both the front and back of the list. The Chunk type is not 59 | exposed publicly, but there are three ways to construct a Chunk. 60 | 61 | < yieldPure :: Builder -> DList (Chunk m) 62 | < yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m) 63 | < yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m) 64 | 65 | If your splice output can be calculated at load time, then you should use 66 | `yieldPure` or one of its variants. When you do this, Heist can concatenate 67 | all adjacent pure chunks into a single precalculated ByteString that can be 68 | rendered very efficiently. If your template needs a value that has to be 69 | calculated at runtime, then you should use the `yieldRuntime` constructor and 70 | supply a computation in the RuntimeSplice monad transformer that is 71 | parameterized by `m` which we saw above is the runtime monad. Occasionally 72 | you might want to run a runtime side effect that doesn't actually insert any 73 | data into your template. The `yieldRuntimeEffect` function gives you that 74 | capability. 75 | 76 | An Example 77 | ========== 78 | 79 | With that background, let's get to a real example. 80 | 81 | > stateSplice :: C.Splice (StateT Int IO) 82 | > stateSplice = return $ C.yieldRuntimeText $ do 83 | > val <- lift get 84 | > return $ pack $ show (val+1) 85 | 86 | Here we see that our splice's runtime monad is `StateT Int IO`. This makes 87 | for a simple example that can clearly demonstrate the different contexts that 88 | we are operating in. To make things more clear, here's a version with some 89 | print statements that clarify the details of which monad is executed when. 90 | 91 | > stateSplice2 :: C.Splice (StateT Int IO) 92 | > stateSplice2 = do 93 | > -- :: C.Splice (StateT Int IO) 94 | > lift $ putStrLn "This executed at load time" 95 | > let res = C.yieldRuntimeText $ do 96 | > -- :: RuntimeSplice (StateT Int IO) a 97 | > lift $ lift $ putStrLn "This executed at run/render time" 98 | > val <- lift get 99 | > return $ pack $ show (val+1) 100 | > lift $ putStrLn "This also executed at load time" 101 | > return res 102 | 103 | Note here that even though the type parameter to C.Splice is a monad, it is not 104 | a monad transformer. RuntimeSplice, however, is. Now let's look at a simple 105 | load function that sets up a default HeistState and loads templates from a 106 | directory with compiled splices. 107 | 108 | > load :: MonadIO n 109 | > => FilePath 110 | > -> Splices (C.Splice n) 111 | > -> IO (HeistState n) 112 | > load baseDir splices = do 113 | > tmap <- runExceptT $ do 114 | > let sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices 115 | > & scCompiledSplices .~ splices 116 | > & scTemplateLocations .~ [loadTemplates baseDir] 117 | > ExceptT $ initHeist $ emptyHeistConfig & hcNamespace .~ "" 118 | > & hcErrorNotBound .~ False 119 | > & hcSpliceConfig .~ sc 120 | > either (error . concat) return tmap 121 | 122 | Here's a function demonstrating all of this in action. 123 | 124 | > runWithStateSplice :: FilePath 125 | > -> IO ByteString 126 | > runWithStateSplice baseDir = do 127 | > hs <- load baseDir ("div" ## stateSplice) 128 | > let runtime = fromJust $ C.renderTemplate hs "index" 129 | > builder <- evalStateT (fst runtime) 2 130 | > return $ toByteString builder 131 | 132 | First this function loads the templates with the above compiled splice. You 133 | have to specify all the compiled splices in the call to loadTemplates because 134 | loadTemplates takes care of compiling all the templates up front. If you were 135 | able to bind compiled splices later, then all the templates would have to be 136 | recompiled, a potentially expensive operation. Next, the function renders the 137 | template called "index" using a runtime (StateT Int IO) seeded with a value of 138 | 2 and returns the resulting ByteString. 139 | 140 | Now let's look at a more complicated example. We want to render a data 141 | structure with a compiled splice. 142 | 143 | > data Person = Person 144 | > { pFirstName :: Text 145 | > , pLastName :: Text 146 | > , pAge :: Int 147 | > } 148 | > 149 | > personSplices :: Monad n 150 | > => Splices (RuntimeSplice n Person -> C.Splice n) 151 | > personSplices = mapV (C.pureSplice . C.textSplice) $ do 152 | > "firstName" ## pFirstName 153 | > "lastName" ## pLastName 154 | > "age" ## pack . show . pAge 155 | > 156 | > peopleSplice :: (Monad n) 157 | > => RuntimeSplice n [Person] 158 | > -> C.Splice n 159 | > peopleSplice = C.manyWithSplices C.runChildren personSplices 160 | > 161 | > allPeopleSplice :: C.Splice (StateT [Person] IO) 162 | > allPeopleSplice = peopleSplice (lift get) 163 | > 164 | > personListTest :: FilePath 165 | > -> IO ByteString 166 | > personListTest baseDir = do 167 | > hs <- load baseDir ("people" ## allPeopleSplice) 168 | > let runtime = fromJust $ C.renderTemplate hs "people" 169 | > builder <- evalStateT (fst runtime) 170 | > [ Person "John" "Doe" 42 171 | > , Person "Jane" "Smith" 21 172 | > ] 173 | > return $ toByteString builder 174 | 175 | 176 | Disadvantages of Compiled Heist 177 | =============================== 178 | 179 | Compiled Heist is faster than the original interpreted approach, but as with 180 | most things in computing there is a tradeoff. Compiled Heist is strictly less 181 | powerful than interpreted Heist. There are two things that compiled Heist 182 | loses: the ability to bind new splices on the fly at runtime and splice 183 | recursion/composability. 184 | 185 | The first point follows immediately from the definition of compiled Heist. 186 | When you decide to do all your splice DOM traversals once at load time you're 187 | unavoidably limited to only those splices that you defined at load time. But 188 | this seems to be a good pattern to use in general because debugging your 189 | splices will be easier if you don't have to consider the possibility that 190 | the handler that binds them didn't run. 191 | 192 | The loss of recursion/composability happens because of the change in the type 193 | signature of splices. Interpreted splices are a essentially function `[Node] 194 | -> m [Node]`. This means that the output of one splice can be the input of 195 | another splice (including itself). Compiled splices are a function `[Node] -> 196 | IO (DList (Chunk m))`. Therefore, once a splice processes some nodes, the 197 | output is no longer something that can be passed into other splices. 198 | 199 | This composability turns out to be a very powerful feature. Head merging is 200 | one feature that can't be done without it. Head merging allows you to put 201 | `` tags anyhere in any template and have them all merged into a single 202 | `` tag at the top of your HTML document. This is useful because it allows 203 | you to keep concerns localized. For instance, you can have a template 204 | represent a small piece of functionality that uses a less common javascript or 205 | CSS file. Instead of having to depend on that resource being included in the 206 | top-level `` tag, you can include it in a `` tag right where you're 207 | using it. Then it will only be included on your pages when you are using the 208 | markup that needs it. 209 | 210 | Our implementation of head merging uses a splice bound to the `` tag. 211 | This splice removes all the `` nodes from its children, combines them, and 212 | inserts them as its first child. This won't work unless the `` splice 213 | first runs all its children to make sure all `` and `` tags have 214 | happened first. And that is impossible to do with compiled splices. 215 | 216 | To get around this problem we added the concept of load time splices. Load 217 | time splices are just interpreted splices that are completely executed at load 218 | time. If interpreted splices have type `[Node] -> m [Node]` where m is the 219 | runtime monad, then load time splices have type `[Node] -> IO [Node]`, where 220 | IO is the monad being executed at load time. Load time splices give you the 221 | power and composability of interpreted splices as long as they are performing 222 | transformations that don't require runtime data. All of the built-in splices 223 | that we ship with Heist work as load time splices. So you can still have head 224 | merging by including our html splice in the load time splice list in your 225 | HeistConfig. 226 | 227 | 228 | A More Involved Example 229 | ======================= 230 | 231 | The person example above is a very common and useful pattern for using dynamic 232 | data in splices. But it has the simplification that it always generates 233 | output the same way. Sometimes you might want a splice's output to have one 234 | form in some cases and a different form in other cases. A simple example is a 235 | splice that reads some kind of a key from a request parameter then looks that 236 | key up in some kind of map. If the key is present the splice uses its child 237 | nodes as a view for the retrieved value, otherwise it outputs an error message. 238 | 239 | This pattern is a little tricky because you're making decisions about what to 240 | render based on runtime data, but the actual rendering of child nodes has to 241 | be done at load time. To bridge the gap and allow communication between load 242 | time and runtime processing we provide the Promise data type. A Promise is 243 | kind of like an IORef except that operations on them are restricted to the 244 | appropriate Heist context. You create a new empty promise in the HeistT n IO 245 | (load time) monad, and you operate on it in the RuntimeSplice monad. 246 | 247 | Here's an example of how to use a promise manually to render a splice 248 | differently in the case of failure. 249 | 250 | < failingSplice :: MonadSnap m => C.Splice m 251 | < failingSplice = do 252 | < promise <- C.newEmptyPromise 253 | < outputChildren <- C.withSplices C.runChildren splices (C.getPromise promise) 254 | < return $ C.yieldRuntime $ do 255 | < -- :: RuntimeSplice m Builder 256 | < mname <- lift $ getParam "username" 257 | < let err = return $ fromByteString "Must supply a username" 258 | < single name = do 259 | < euser <- lift $ lookupUser name 260 | < either (return . fromByteString . encodeUtf8 . T.pack) 261 | < doUser euser 262 | < where 263 | < doUser value = do 264 | < C.putPromise promise (name, value) 265 | < C.codeGen outputChildren 266 | < maybe err single mname 267 | < 268 | < 269 | < splices :: Monad n 270 | < => Splices (RuntimeSplice n (Text, Text) -> C.Splice n) 271 | < splices = mapS (C.pureSplice . C.htmlNodeSplice) $ do 272 | < "user" ## (:[]) . TextNode . fst 273 | < "value" ## (:[]) . TextNode . snd 274 | 275 | -------------------------------------------------------------------------------- /test/suite/Heist/Tutorial/Imports.hs: -------------------------------------------------------------------------------- 1 | module Heist.Tutorial.Imports 2 | ( module Blaze.ByteString.Builder 3 | , module Control.Monad 4 | , module Control.Monad.Trans 5 | , module Data.Maybe 6 | , module Data.Monoid 7 | , ST.get 8 | , ST.StateT(..) 9 | , ST.evalStateT 10 | , T.Text 11 | , T.pack 12 | , ByteString 13 | , runExceptT 14 | , ExceptT(..) 15 | ) where 16 | 17 | import Blaze.ByteString.Builder 18 | import Control.Monad 19 | import Control.Monad.Trans 20 | import Control.Monad.Trans.Except (ExceptT(..), runExceptT) 21 | import qualified Control.Monad.Trans.State as ST 22 | import Data.ByteString.Char8 (ByteString) 23 | import Data.Maybe 24 | import Data.Monoid 25 | import qualified Data.Text as T 26 | 27 | -------------------------------------------------------------------------------- /test/suite/TestSuite.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Directory 4 | import Test.Framework (defaultMain, testGroup) 5 | 6 | import qualified Heist.Interpreted.Tests 7 | import qualified Heist.Compiled.Tests 8 | import qualified Heist.Tests 9 | 10 | main :: IO () 11 | main = do 12 | -- Need to change directory after we switched to cabal test infra 13 | setCurrentDirectory "test" 14 | defaultMain tests 15 | where tests = [ testGroup "Heist.Interpreted.Tests" 16 | Heist.Interpreted.Tests.tests 17 | , testGroup "Heist.Compiled.Tests" 18 | Heist.Compiled.Tests.tests 19 | , testGroup "Heist.Tests" 20 | Heist.Tests.tests 21 | ] 22 | -------------------------------------------------------------------------------- /test/templates-bad/apply-missing-attr.tpl: -------------------------------------------------------------------------------- 1 | 2 | noroot 3 | 4 | -------------------------------------------------------------------------------- /test/templates-bad/apply-template-not-found.tpl: -------------------------------------------------------------------------------- 1 | 2 | This template is missing 3 | 4 | -------------------------------------------------------------------------------- /test/templates-bad/bind-infinite-loop.tpl: -------------------------------------------------------------------------------- 1 |

line

 2 | 3 | -------------------------------------------------------------------------------- /test/templates-bad/bind-missing-attr.tpl: -------------------------------------------------------------------------------- 1 |

line

 2 | 3 | -------------------------------------------------------------------------------- /test/templates-defer/test.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /test/templates-loaderror/_error.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates-loaderror/_ok.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates-loaderror/test.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /test/templates-no-ns/test.tpl: -------------------------------------------------------------------------------- 1 | Hello world 2 | 3 |

This is a test

4 | -------------------------------------------------------------------------------- /test/templates-ns-nested/test.tpl: -------------------------------------------------------------------------------- 1 |
2 | -------------------------------------------------------------------------------- /test/templates-nsbind/nsbind.tpl: -------------------------------------------------------------------------------- 1 | Alpha 2 | 3 | Beta 4 | 5 | Gamma 6 | 7 | 8 | -------------------------------------------------------------------------------- /test/templates-nsbind/nsbinderror.tpl: -------------------------------------------------------------------------------- 1 | Alpha 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /test/templates-nscall/_call.tpl: -------------------------------------------------------------------------------- 1 | Called 2 | 3 | -------------------------------------------------------------------------------- /test/templates-nscall/_invalid.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates-nscall/nscall.tpl: -------------------------------------------------------------------------------- 1 | Top 2 | 3 | Inside 1 4 | 5 | Inside 2 6 | 7 | -------------------------------------------------------------------------------- /test/templates/a.tpl: -------------------------------------------------------------------------------- 1 | /a 2 | -------------------------------------------------------------------------------- /test/templates/attr_splice.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | -------------------------------------------------------------------------------- /test/templates/attrs.tpl: -------------------------------------------------------------------------------- 1 | Empty attribute 2 | No ident capture 3 |
4 | -------------------------------------------------------------------------------- /test/templates/attrsubtest1.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/attrsubtest2.tpl: -------------------------------------------------------------------------------- 1 | asdflinkfoo 2 | -------------------------------------------------------------------------------- /test/templates/backslash.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/bar/a.tpl: -------------------------------------------------------------------------------- 1 | /bar/a 2 | -------------------------------------------------------------------------------- /test/templates/bar/index.tpl: -------------------------------------------------------------------------------- 1 | /bar/index 2 | -------------------------------------------------------------------------------- /test/templates/bind-apply-interaction/_outer.tpl: -------------------------------------------------------------------------------- 1 | ====== 2 | This is a test. 3 | bind content 4 | Another test line. 5 | 6 | Last test line. 7 | -------------------------------------------------------------------------------- /test/templates/bind-apply-interaction/caller.tpl: -------------------------------------------------------------------------------- 1 | apply content 2 | -------------------------------------------------------------------------------- /test/templates/bind-attrs.tpl: -------------------------------------------------------------------------------- 1 | zzzzz 2 |
3 | -------------------------------------------------------------------------------- /test/templates/bind_param.tpl: -------------------------------------------------------------------------------- 1 |
    • worldHi therehello 2 | -------------------------------------------------------------------------------- /test/templates/cache.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /test/templates/div_expansion.tpl: -------------------------------------------------------------------------------- 1 | foo
    2 | -------------------------------------------------------------------------------- /test/templates/foo/a.tpl: -------------------------------------------------------------------------------- 1 | /foo/a 2 | -------------------------------------------------------------------------------- /test/templates/foo/b.tpl: -------------------------------------------------------------------------------- 1 | /foo/b 2 | -------------------------------------------------------------------------------- /test/templates/foo/markdown-chdir.tpl: -------------------------------------------------------------------------------- 1 | Different directory markdown 2 | 3 | This file doesn't have any actual test code referring to it because compiled 4 | Heist will automatically fail the whole test suite if the case tested by this 5 | template isn't tested correctly. 6 | -------------------------------------------------------------------------------- /test/templates/foo/markdown-origdir.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | -------------------------------------------------------------------------------- /test/templates/foo/test2.md: -------------------------------------------------------------------------------- 1 | This *is* another test. 2 | -------------------------------------------------------------------------------- /test/templates/head_merge/index.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |
    index page
    6 |     7 | -------------------------------------------------------------------------------- /test/templates/head_merge/nav.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |
    nav bar
    5 | -------------------------------------------------------------------------------- /test/templates/head_merge/wrap.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /test/templates/index.tpl: -------------------------------------------------------------------------------- 1 | 3 | ultralongname 4 | 5 |
    6 | /index 7 |
    8 | 9 | -------------------------------------------------------------------------------- /test/templates/ioc.tpl: -------------------------------------------------------------------------------- 1 | 2 | Inversion of control content 3 | 4 | -------------------------------------------------------------------------------- /test/templates/json.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/json_array.tpl: -------------------------------------------------------------------------------- 1 | , and 2 | -------------------------------------------------------------------------------- /test/templates/json_object.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/json_snippet.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/markdown.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/namespaces.tpl: -------------------------------------------------------------------------------- 1 | Alpha 2 | Inside foo 3 | Beta 4 | Inside h:foo 5 | End 6 | -------------------------------------------------------------------------------- /test/templates/page.tpl: -------------------------------------------------------------------------------- 1 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /test/templates/pandoc.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/pandocdiv.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/templates/people.tpl: -------------------------------------------------------------------------------- 1 | 2 |

    , : years old

    3 |     4 | -------------------------------------------------------------------------------- /test/templates/post.tpl: -------------------------------------------------------------------------------- 1 | 2 |

    3 |

    4 |     5 | -------------------------------------------------------------------------------- /test/templates/readme.txt: -------------------------------------------------------------------------------- 1 | This file intentionally doesn't have a .tpl extension to get test coverage for this case. 2 | -------------------------------------------------------------------------------- /test/templates/rss.xtpl: -------------------------------------------------------------------------------- 1 | http://www.devalot.com/ 2 | -------------------------------------------------------------------------------- /test/templates/test.md: -------------------------------------------------------------------------------- 1 | This *is* a test. 2 | -------------------------------------------------------------------------------- /test/templates/textarea_expansion.tpl: -------------------------------------------------------------------------------- 1 | foo 2 | -------------------------------------------------------------------------------- /test/templates/title_expansion.tpl: -------------------------------------------------------------------------------- 1 | foo<mytext/> 2 | -------------------------------------------------------------------------------- /test/templates/user/admin/main.tpl: -------------------------------------------------------------------------------- 1 | 2 | Admin Page 3 | 4 | 5 | -------------------------------------------------------------------------------- /test/templates/user/admin/menu.tpl: -------------------------------------------------------------------------------- 1 |
      2 |
    • Manage Users
      • 3 |
    • Configure Site
      • 4 |
    5 | -------------------------------------------------------------------------------- /test/templates/user/main.tpl: -------------------------------------------------------------------------------- 1 | 2 | User Page 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /test/templates/user/menu.tpl: -------------------------------------------------------------------------------- 1 |
      2 |
    • Entries
      • 3 |
    • Post
      • 4 |
    • Logout
      • 5 |
    6 | --------------------------------------------------------------------------------