hakyll 4.8.3.2 → 4.17.0.0
raw patch · 162 files changed
Files
- CHANGELOG.md +873/−0
- LICENSE +1/−1
- data/example/css/default.css +122/−37
- data/example/site.hs +0/−1
- data/example/templates/default.html +16/−16
- data/example/templates/post.html +11/−8
- data/templates/atom.xml +3/−0
- data/templates/feed-item.json +8/−0
- data/templates/feed.json +18/−0
- hakyll.cabal +186/−132
- lib/Data/List/Extended.hs +15/−0
- lib/Data/Yaml/Extended.hs +24/−0
- lib/Hakyll.hs +72/−0
- lib/Hakyll/Check.hs +294/−0
- lib/Hakyll/Commands.hs +170/−0
- lib/Hakyll/Core/Compiler.hs +232/−0
- lib/Hakyll/Core/Compiler/Internal.hs +364/−0
- lib/Hakyll/Core/Compiler/Require.hs +137/−0
- lib/Hakyll/Core/Configuration.hs +165/−0
- lib/Hakyll/Core/Dependencies.hs +237/−0
- lib/Hakyll/Core/File.hs +93/−0
- lib/Hakyll/Core/Identifier.hs +169/−0
- lib/Hakyll/Core/Identifier/Pattern.hs +266/−0
- lib/Hakyll/Core/Identifier/Pattern/Internal.hs +79/−0
- lib/Hakyll/Core/Item.hs +47/−0
- lib/Hakyll/Core/Item/SomeItem.hs +23/−0
- lib/Hakyll/Core/Logger.hs +107/−0
- lib/Hakyll/Core/Metadata.hs +168/−0
- lib/Hakyll/Core/Provider.hs +59/−0
- lib/Hakyll/Core/Provider/Internal.hs +202/−0
- lib/Hakyll/Core/Provider/Metadata.hs +151/−0
- lib/Hakyll/Core/Provider/MetadataCache.hs +74/−0
- lib/Hakyll/Core/Routes.hs +356/−0
- lib/Hakyll/Core/Rules.hs +495/−0
- lib/Hakyll/Core/Rules/Internal.hs +116/−0
- lib/Hakyll/Core/Runtime.hs +539/−0
- lib/Hakyll/Core/Store.hs +233/−0
- lib/Hakyll/Core/UnixFilter.hs +160/−0
- lib/Hakyll/Core/Util/File.hs +114/−0
- lib/Hakyll/Core/Util/Parser.hs +31/−0
- lib/Hakyll/Core/Util/String.hs +81/−0
- lib/Hakyll/Core/Writable.hs +56/−0
- lib/Hakyll/Main.hs +203/−0
- lib/Hakyll/Preview/Poll.hs +109/−0
- lib/Hakyll/Preview/Server.hs +35/−0
- lib/Hakyll/Web/CompressCss.hs +105/−0
- lib/Hakyll/Web/Feed.hs +363/−0
- lib/Hakyll/Web/Html.hs +309/−0
- lib/Hakyll/Web/Html/RelativizeUrls.hs +52/−0
- lib/Hakyll/Web/Meta/JSONLD.hs +115/−0
- lib/Hakyll/Web/Meta/OpenGraph.hs +71/−0
- lib/Hakyll/Web/Meta/TwitterCard.hs +63/−0
- lib/Hakyll/Web/Paginate.hs +154/−0
- lib/Hakyll/Web/Pandoc.hs +253/−0
- lib/Hakyll/Web/Pandoc/Biblio.hs +240/−0
- lib/Hakyll/Web/Pandoc/Binary.hs +31/−0
- lib/Hakyll/Web/Pandoc/FileType.hs +101/−0
- lib/Hakyll/Web/Redirect.hs +99/−0
- lib/Hakyll/Web/Tags.hs +356/−0
- lib/Hakyll/Web/Template.hs +178/−0
- lib/Hakyll/Web/Template/Context.hs +520/−0
- lib/Hakyll/Web/Template/Internal.hs +260/−0
- lib/Hakyll/Web/Template/Internal/Element.hs +291/−0
- lib/Hakyll/Web/Template/Internal/Trim.hs +95/−0
- lib/Hakyll/Web/Template/List.hs +95/−0
- src/Data/List/Extended.hs +0/−15
- src/Data/Yaml/Extended.hs +0/−20
- src/Hakyll.hs +0/−60
- src/Hakyll/Check.hs +0/−253
- src/Hakyll/Commands.hs +0/−162
- src/Hakyll/Core/Compiler.hs +0/−180
- src/Hakyll/Core/Compiler/Internal.hs +0/−265
- src/Hakyll/Core/Compiler/Require.hs +0/−121
- src/Hakyll/Core/Configuration.hs +0/−134
- src/Hakyll/Core/Dependencies.hs +0/−146
- src/Hakyll/Core/File.hs +0/−85
- src/Hakyll/Core/Identifier.hs +0/−80
- src/Hakyll/Core/Identifier/Pattern.hs +0/−322
- src/Hakyll/Core/Item.hs +0/−63
- src/Hakyll/Core/Item/SomeItem.hs +0/−23
- src/Hakyll/Core/Logger.hs +0/−97
- src/Hakyll/Core/Metadata.hs +0/−138
- src/Hakyll/Core/Provider.hs +0/−43
- src/Hakyll/Core/Provider/Internal.hs +0/−202
- src/Hakyll/Core/Provider/Metadata.hs +0/−151
- src/Hakyll/Core/Provider/MetadataCache.hs +0/−62
- src/Hakyll/Core/Routes.hs +0/−194
- src/Hakyll/Core/Rules.hs +0/−223
- src/Hakyll/Core/Rules/Internal.hs +0/−109
- src/Hakyll/Core/Runtime.hs +0/−276
- src/Hakyll/Core/Store.hs +0/−197
- src/Hakyll/Core/UnixFilter.hs +0/−159
- src/Hakyll/Core/Util/File.hs +0/−56
- src/Hakyll/Core/Util/Parser.hs +0/−25
- src/Hakyll/Core/Util/String.hs +0/−78
- src/Hakyll/Core/Writable.hs +0/−56
- src/Hakyll/Init.hs +0/−96
- src/Hakyll/Main.hs +0/−128
- src/Hakyll/Preview/Poll.hs +0/−119
- src/Hakyll/Preview/Server.hs +0/−54
- src/Hakyll/Web/CompressCss.hs +0/−59
- src/Hakyll/Web/Feed.hs +0/−131
- src/Hakyll/Web/Html.hs +0/−184
- src/Hakyll/Web/Html/RelativizeUrls.hs +0/−52
- src/Hakyll/Web/Paginate.hs +0/−126
- src/Hakyll/Web/Pandoc.hs +0/−164
- src/Hakyll/Web/Pandoc/Biblio.hs +0/−115
- src/Hakyll/Web/Pandoc/Binary.hs +0/−31
- src/Hakyll/Web/Pandoc/FileType.hs +0/−74
- src/Hakyll/Web/Tags.hs +0/−344
- src/Hakyll/Web/Template.hs +0/−263
- src/Hakyll/Web/Template/Context.hs +0/−379
- src/Hakyll/Web/Template/Internal.hs +0/−221
- src/Hakyll/Web/Template/List.hs +0/−91
- src/Init.hs +132/−0
- tests/Hakyll/Core/Dependencies/Tests.hs +33/−11
- tests/Hakyll/Core/Identifier/Tests.hs +37/−20
- tests/Hakyll/Core/Provider/Metadata/Tests.hs +20/−16
- tests/Hakyll/Core/Provider/Tests.hs +4/−5
- tests/Hakyll/Core/Routes/Tests.hs +5/−5
- tests/Hakyll/Core/Rules/Tests.hs +7/−8
- tests/Hakyll/Core/Runtime/Tests.hs +216/−9
- tests/Hakyll/Core/Store/Tests.hs +16/−16
- tests/Hakyll/Core/UnixFilter/Tests.hs +34/−16
- tests/Hakyll/Core/Util/String/Tests.hs +17/−5
- tests/Hakyll/Web/CompressCss/Tests.hs +66/−0
- tests/Hakyll/Web/Feed/Tests.hs +68/−0
- tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs +6/−3
- tests/Hakyll/Web/Html/Tests.hs +50/−10
- tests/Hakyll/Web/Pandoc/Biblio/Tests.hs +164/−0
- tests/Hakyll/Web/Pandoc/FileType/Tests.hs +5/−4
- tests/Hakyll/Web/Tags/Tests.hs +42/−0
- tests/Hakyll/Web/Template/Context/Tests.hs +16/−8
- tests/Hakyll/Web/Template/Tests.hs +97/−25
- tests/TestSuite.hs +15/−2
- tests/TestSuite/Util.hs +40/−18
- tests/data/biblio/chicago.csl +648/−0
- tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden +16/−0
- tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden +20/−0
- tests/data/biblio/cites-multiple.markdown +7/−0
- tests/data/biblio/default.html +11/−0
- tests/data/biblio/page.markdown +5/−0
- tests/data/biblio/refs.bib +8/−0
- tests/data/biblio/refs.yaml +18/−0
- tests/data/biblio/refs2.yaml +18/−0
- tests/data/embed.html +1/−0
- tests/data/example.md.metadata +2/−0
- tests/data/just-meta.html +7/−0
- tests/data/just-meta.html.out +7/−0
- tests/data/partial-helper.html +3/−0
- tests/data/partial.html +3/−0
- tests/data/partial.html.out +7/−0
- tests/data/posts/2018-09-26.md +1/−0
- tests/data/posts/2019/05/10/tomorrow.md +1/−0
- tests/data/strip.html +34/−0
- tests/data/strip.html.out +18/−0
- tests/data/template-empty.html +0/−0
- web/site.hs +89/−0
+ CHANGELOG.md view
@@ -0,0 +1,873 @@+---+title: Releases+---++# Releases++## 4.17.0.0++This release is nearly identical to 4.16.8.0. However, 4.16.8.0 contains a breaking change+which was not caught. Therefore, release 4.16.8.0 is deprecated on Hackage, and 4.17.0.0 should+be preferred++- Added support for QuickCheck 2.17 and 2.18 (#1099).++## 4.16.8.0++- Added support for djot for pandoc 3.1.12+ (#1096)+- Added support for pandoc 3.9 (#1095)+- Added support for declaring metadata-only dependencies (#1084).+- Added support for AsciiDoc for pandoc 3.8.3+ (#1089).+- Added support for tasty-1.5.4+ by disabling threaded tests.++## Hakyll 4.16.7.1 (2025-09-06)++- Added support for pandoc 3.8 (#1080).++## Hakyll 4.16.7.0 (2025-08-29)++- Validate the output of XML-based feed functions such as `renderRss` by default (#1078).+- Bump `containers` upper bound to include 0.8.+- Add support for Typst (#1067).++## Hakyll 4.16.6.0 (2025-02-18)++- Do not crawl directories for which we do not have permissions+ with `Hakyll.Core.Util.File.getRecursiveContents`. This used to+ throw an exception.+- Do not return broken symbolic links from+ `Hakyll.Core.Util.File.getRecursiveContents`. This used to cause+ subsequent code to throw exceptions (e.g., when it attempts to+ `getModificationTime`) (#1065) (Contribution by Wren Romano).+- Ignore files in `dist-newstyle` and `.stack-work` directories, which+ are Haskell build directories.++## Hakyll 4.16.5.0 (2025-01-11)++- GHC 9.12 compatibility: bump `template-haskell` upper bound to include 2.23+- Add support for `nocite` metadata field to `processPandocBiblio` and+ `processPandocBiblios` (#1058) (contribution by Tony Zorman)++## Hakyll 4.16.4.0 (2024-12-08)++- Fixed an issue where compressing CSS with `clamp` expressions would+ result in invalid CSS (#1021) (contribution by Laurent P. René de Cotret)+- Added `boolFieldM` (#1044) (contribution by 0xd34df00d)+- Run HLint as part of GitHub Actions (#1045) (contribution by Yoo Chung)+- Running the `check` command will now consider URLs that respond with a 3XX code+ (redirection) to be alive.+- Bump `data-default` upper bound to include 0.8+- Bump `pandoc` upper bound to include 3.6++## Hakyll 4.16.3.0 (2024-10-24)++- Bump `pandoc` upper bound to include up to version 3.5+ (#1041, #1042, #1047) (contributions by Alexander Batischev)+- Add `renderPandocItemWithTransformM` and `pandocItemCompilerWithTransformM`+ (#1020) (contribution by Tony Zorman)++## Hakyll 4.16.2.2 (2024-07-05)++- Bump `tasty-quickcheck` upper bound to 0.12 (contribution by Alexander+ Batischev)+- GHC 9.10 compatibility: bump `template-haskell` upper bound to 0.23, fix+ `foldl'` imports (as the function is now part of `Prelude`) (contribution by+ David Binder and Alexander Batischev)++## Hakyll 4.16.2.1 (2024-06-02)++- Fix "thread blocked indefinitely in an MVar operation" errors caused by+ exceptions produced by `Items` (#1014) (contribution by Jasper Van der Jeugt)+- Improve `+watchServer` and `+previewServer` error messages: they now explain+ *how* to enable the flag when the user tries to run `watch`/`preview`+ without them (#1022) (contribution by Jasper Van der Jeugt)+- Assorted fixes and improvements to documentation (contributions by Alexander+ Batischev, Adrien, Tanya Bouman)+- Bump `bytestring` upper bound to 0.13 (contribution by Alexander Batischev)+- Bump `deepseq` upper bound to 1.6 (contribution by Laurent P. René de Cotret)+- Bump `template-haskell` upper bound to 2.22 (contribution by Laurent P. René+ de Cotret)+- Bump `text` upper bound to 2.2 (contribution by Laurent P. René de Cotret)+- Bump `file-embed` upper bound to 0.0.17 (contribution by Alexander Batischev)+- Bump `warp` upper bound to 3.5 (contribution by Alexander Batischev)+- Bump `filepath` upper bound to 1.6 (contribution by Alexander Batischev)+- Bump `containers` upper bound to 0.8 (contribution by Andreas Abel)+- Bump `time` upper bound to 1.15 (contribution by Andreas Abel)+- Bump `QuickCheck` upper bound to 2.16 (contribution by Andreas Abel)+- Bump `pandoc` upper bound to 3.3 (contribution by Alexander Batischev)++## Hakyll 4.16.2.0 (2023-09-20)++- Add errors for multiple `match`es that are routed to the same file+ (contribution by Jasper van der Jeugt)+- Fix Hakyll.Web.Pandoc.Biblio tests failing with Pandoc 3.1.8 (contribution by+ Alexander Batischev)+- Bump `tasty` upper bound to 1.6 (contribution by Alexander Batischev)++## Hakyll 4.16.1.0 (2023-08-23)++- Rewrite async scheduler; improves scaling and resource usage+- Add JSON Feed support (contribution by Berk Özkütük)+- Bump `aeson` upper bound to aeson 2.3 (contribution by Alexander Batischev)+- Bump `optparse-applicative` upper bound to aeson 0.19 (contribution by+ Alexander Batischev)++## Hakyll 4.16.0.0 (2023-04-27)++- Bump `base` *lower* bound to 4.12 (GHC >= 8.6). Hakyll already failed to build+ on earlier versions due to the template-haskell requirement, and nobody+ complained about that, so I assume nobody cares if the support is properly+ dropped (contribution by Alexander Batischev)+- Export `Hakyll.Tags.simpleRenderLink` (contribution by Alexander Batischev)+- Add `Hakyll.Web.Pandoc.Biblio.pandocBibliosCompiler` to load multiple bib+ files by glob (contribution by Liang-Ting Chen)+- Fix "Store.set: resource busy" error (contribution by Jasper Van der Jeugt)+- Teach `Hakyll.Web.Template.Context.getItemUTC` about another date format,+ "%d.%m.%Y" (contribution by dukzcry)+- Add `Hakyll.Web.Html.withTagListM`, a monadic version of `withTagList`+ (contribution by 0xd34df00d)+- Fix all the warnings and enable `-Werror` in CI (contribution by Alexander+ Batischev)+- Miscellaneous updates and fixes to the docs (contributions by Tony Zorman,+ Alexander Batischev, malteneuss, Agustín Mista, Martin Bukatovič, Muhammad+ Aviv Burhanudin, Jacek Galowicz, Daniel Mlot, Yoo Chung, Robert Pearce)+- Export `Hakyll.defaultCommands`, i.e. Hakyll's set of commands (`build`,+ `check`, `clean` etc.) (contribution by Alexander Batischev)+- Add a `Hakyll.Core.Configuration.Configuration.previewSettings` field which+ lets the user override the settings used by the preview server (contribution+ by Christopher League and Brian McKenna)+- Make email address in RSS/Atom feeds optional (just set it to an empty string)+ (contribution by Robert)+- `Hakyll.Web.Meta.TwitterCard`: use `name` instead of `property` for better+ spec compliance (contribution by ncaq)+- Add a `Hakyll.Core.Configuration.Configuration.checkHtmlFile` predicate which+ dictates what files will get link-checked by the `check` command. Default+ predicate accepts files with .html and .xhtml extensions (contribution by+ Yoo Chung, with earlier contribution from Michael Orlitzky)+- Add support for GHC 9.2 (contribution by Laurent P. René de Cotret)+- Bump `optparse-applicative` upper bound to allow 0.17 (contribution by+ Alexander Batischev)+- Bump `pandoc` upper bound to allow 2.19 (contribution by Alexander Batischev)+- Allow `text` 2.0 (contribution by Alexander Batischev)+- Bump `vector` upper bound to allow 0.13 (contribution by Alexander Batischev)+- Allow `aeson` 2.1 (contribution by Alexander Batischev)+- Bump `fsnotify` upper bound to allow 0.4 (contribution by Alexander Batischev)+- Bump `resourcet` upper bound to allow 1.3 (contribution by Alexander+ Batischev)+- Bump `template-haskell` upper bound to 2.20 (GHC 9.4.3) (contribution by+ Alexander Batischev)+- Allow `pandoc` 3.0. Note that the behavior of Hakyll's `readPandocBiblios` and+ `readPandocBiblio` is different whether pandoc 2 or 3 is installed+ (contribution by Laurent P. René de Cotret)+- Bump `mtl` upper bound to allow 2.3 (contribution by Alexander Batischev)+- Bump `pandoc` upper bound to allow 3.1 (contribution by Laurent P. René de+ Cotret)+- Bump `template-haskell` upper bound to 2.21 and `time` to 1.12 (GHC 9.6.1)+ (contribution by Laurent P. René de Cotret)++## Hakyll 4.15.1.1 (2022-01-20)++- Extend the documentation for `Hakyll.Core.Identifier` (contribution by+ malteneuss)+- Fix yet another regression caused by new dependency checking code+ (contribution by Laurent P. René de Cotret)+- Bump `pandoc` upper bound to allow 2.17 (contribution by Alexander Batischev)+- Website now points to Hackage rather than its own (often outdated) version of+ the docs (contribution by Jasper Van der Jeugt)++## Hakyll 4.15.1.0 (2021-10-25)++- Add `Hakyll.Web.Pandoc.Biblio` functions `readPandocBiblios` and+ `processPandocBiblios`, which let one use multiple bibliographies+ (contribution by Benjamin Eskola)+- Preserve file extension of bibliography files when passing them to Pandoc.+ This enables one to use not just BibTex, but also YAML and JSON files+ (contribution by Benjamin Eskola)+- Fix URL extraction for `srcset` attribute. This affects+ `Hakyll.Web.HTML.relativizeUrls` and other such functions (contribution by+ Alexander Batischev)+- Bump `bytestring` upper bound to allow 0.11 (contribution by Alexander+ Batischev)+- Bump `pandoc` upper bound to allow 2.15 (contribution by Alexander Batischev)+- Bump `aeson` bounds to allow 2.0 (contribution by Alexander Batischev)++## Hakyll 4.15.0.1 (2021-10-02)++- Add missing test file to the package (contribution by Alexander Batischev)++## Hakyll 4.15.0.0 (2021-10-01)++- Fix dependency cycles detector (contribution by Laurent P. René de Cotret)+- Add `--dry-run` to the `build` command (contribution by Fraser Tweedale)+- Add support for Jupyter notebooks (files with ".ipynb" extension)+ (contribution by fedeinthemix)+- Add `Hakyll.Web.Pandoc.Biblio.processPandocBiblio`, which works with `Item+ Pandoc` and is thus composable with other Pandoc-related compilers and+ functions (contribution by fedeinthemix)+- Speed up the runtime by about 9% (multiple contributions by Fraser Tweedale)+- Tolerate unexpected cache misses by recompiling the item; now there is no need+ to rebuild the entire site to fix cache corruption (contribution by Fraser+ Tweedale)+- Replace `Hakyll.Core.Rules.forceCompile` (introduced in 4.14.1.0) with+ `Hakyll.Core.Compiler.recompilingUnsafeCompiler`. The new facility is more+ versatile and composes better (contribution by Fraser Tweedale)+- Remove dependency on `array` (contribution by Laurent P. René de Cotret)++## Hakyll 4.14.1.0 (2021-08-30)++- Add `Hakyll.Web.Html.demoteHeaderBy` function, which demotes an HTML header by+ a given amount (contribution by Logan McGrath)+- Add `Hakyll.Core.Rules.forceCompile` modifier which forces re-compilation of+ an item even if its file wasn't modified. This is useful for data sources+ which aren't local files (contribution by Fraser Tweedale)+- Add `Hakyll.Web.Tags.getTagsByField` which extracts tags from a given field+ instead of the default "tags" field (contribution by Jim McStanton and+ Alexander Batischev)+- Add `Hakyll.Core.Configuration.shouldWatchIgnore` function and the+ corresponding `watchIgnore` field for `Configuration`. These are used to+ ignore files in watch mode, which is useful when certain files are+ pre-processed and the results are saved into the provider directory+ (contribution by Aron Erben)+- Add `Hakyll.Web.Meta` modules `JSONLD`, `OpenGraph`, and `TwitterCard`. These+ help with semantic web metadata in pages. This adds dependency on `aeson`+ (contribution by Fraser Tweedale)+- Export `Hakyll.Web.Pandoc.Biblio.unCSL` function (contribution by Benjamin+ Bray)+- Make the runtime concurrent, which brings 30% speedups on real-world sites.+ This adds dependencies on `array` and `lifted-async`. Please note that it+ doesn't scale past the number of physical cores; ideas are welcome in+ https://github.com/jaspervdj/hakyll/issues/850 (contribution by+ Laurent P. René de Cotret and Vaibhav Sagar)+- Fix binary's name in the first tutorial (contribution by Alexander Batischev)+- Fix "Empty 'do' block" error in GitHub tutorial (contribution by+ alexandroid000)+- Move #hakyll IRC channel from Freenode to Libera.Chat (by Alexander Batischev+ and henk)+- Replace dependency on `cryptonite` and `memory` with dependency on `hashable`+ (contribution by Laurent P. René de Cotret)+- Bump `file-embed` upper bound to 0.0.15 (contribution by Alexander Batischev)+- Bump `optparse-applicative` upper bound to 0.16 (contribution by Felix Yan)+- Bump `pandoc` upper bound to 2.14 (contribution by Laurent P. René de Cotret)+- Bump `tasty` upper bound to 1.4 (contribution by Felix Yan)+- Bump `template-haskell` upper bound to 2.17, which is shipped with GHC 9+ (contribution by Alexander Batischev)+- Bump `time` upper bound to 1.11 (contribution by Alexander Batischev)++## Hakyll 4.14.0.0 (2021-03-14)++- Add `renderPandocWithTransform` and `renderPandocWithTransformM` (by Norman+ Liu)+- Make sure the initial project is writable (by Tobias Bora)+- Bump `pandoc` to 2.11.*+- Bump `file-embed` upper bound to 0.0.14+- Bump `random` upper bound to 1.2++## Hakyll 4.13.4.1 (2020-09-30)++- Bump `pandoc` to 2.10.*+- Bump upper bound for `template-haskell` to 2.17+- Bump `QuickCheck` upper bound to 2.15++## Hakyll 4.13.4.0 (2020-06-20)++- Miscellaneous Windows-specific fixes and CI (by Laurent P. René de Cotret)+- Bump upper bound for `cryptonite` to 0.28+- Bump upper bound for `tasty` to 1.4++## Hakyll 4.13.3.0 (2020-04-12)++- Fix compilation issue related to `MonadFail` on Windows (by Martín Emanuel)+- Bump upper bound for `warp` to 3.4+- Bump upper bound for `pandoc-citeproc` to 0.18++## Hakyll 4.13.2.0 (2020-03-07)++- Fix compatibility with GHC-8.6 (by Nikolay Yakimov).++## Hakyll 4.13.1.0 (2020-02-26)++- Fix timezone parsing bug with time-1.9+- Remove constant field for homepage title in example site (by Liang-Ting Chen)+- Clean up `stack.yaml` (by Hexirp)+- Use crytonite instead of cryptohash (by Hexirp)+- Expose CLI argument parser internals (by Jim McStanton)+- Support GHC-8.8. Add `MonadFail` instances and constraints (by Veronika+ Romashkina)+- Fix file path compatibility with Windows (by Hexirp)+- Fix logging output flushing in `site server` (by robx)+- Fix spacing of command line usage in `hakyll-init` (by robx)+- Add titles to tag fields by default++## Hakyll 4.13.0.1 (2019-09-18)++- Add missing test files (contribution by Justin Humm)++## Hakyll 4.13.0.0 (2019-08-30)++- Improved documentation in many places (contribution by Bergi)+- Significantly improve error messages when reading and applying templates+ (contribution by Bergi)+ * `empty` and `fail` for `Compiler` now fail without or with a message,+ allowing for much better debug output+ * `renderFeed`, `renderRssWithTemplates` and `renderAtomWithTemplates` now+ take `Template` rather than `String` arguments+- Add option to specify date in directory structure,e.g.+ `posts/2019/05/10/tomorrow.md` (contribution by Taeer Bar-Ya)+- Bump QuickCheck to 2.13++## Hakyll 4.12.5.2 (2019-05-09)++- Bump pandoc to 2.7+- Add `srcset` to the list of URL attributes (contribution by c50a326)+- Expose `getCategory` in `Hakyll.Web.Tags` (contribution by Ng Wei En)+- Fix issue where `published` overwrites the user's context (contribution by+ ncaq)++## Hakyll 4.12.5.1 (2019-02-03)++- Bump pandoc to 2.6+- Bump pandoc-citeproc to 0.16++## Hakyll 4.12.5.0 (2019-01-12)++- Update dependencies (contribution by Hexirp):+ * Bump containers to 0.6+ * Bump yaml to 0.11+ * Bump pandoc to 2.5+ * Bump pandoc-citeproc to 0.15+ * Bump tasty to 1.2+- Correct assertion in unixFilterError test+ (contribution by Jim McStanton)+- Add renderRssWithTemplates, renderAtomWithTemplates+ (contribution by Abhinav Sarkar)+- Speed up hashing in cache (contribution by 0xd34df00d)+- Update type of fromFilePath to use FilePath instead of String+ (contribution by Jim McStanton)+- Drop extension when parsing dates in filepaths (contribution by+ Gabriel Aumala)++## Hakyll 4.12.4.0 (2018-08-13)++- Bump yaml to 0.10+- Bump file-embed to 0.0.11+- Bump QuickCheck to 2.12+- Use makeRelativeToProject with embedFile for stack ghci (contribution by+ Michael Sloan)++## Hakyll 4.12.3.0 (2018-05-29)++- Bump tasty to 1.1+- Bump fsnotify to 0.3++## Hakyll 4.12.2.0++- Bump pandoc to 2.2+- Fix path resolution in Pandoc.Biblio (contribution by knih)++## Hakyll 4.12.1.0++- Fix hakyll-init on older GHC versions+- Make the Pandoc dependency optional++## Hakyll 4.12.0.1++- Bump resourcet to 1.2 in test section++## Hakyll 4.12.0.0++- Add Semigroup instances for existing Monoids (contribution by+ Christian Barcenas)+- Fix issue with CPP and comment containing `/*`+- Add `withTagList` (contribution by Oleg Grenrus)+- Improve CSS compression (contribution by Bergi)+- Bump pandoc-citeproc to 0.14+- Bump resourcet to 1.2+- Bump time to 1.9+- Bump http-types to 0.12+- Bump http-conduit to 2.3+- Bump tasty-quickcheck to 0.10++## Hakyll 4.11.0.0++- Bump binary to 0.9+- Bump pandoc to 2.1+- Bump pandoc-citeproc to 0.13+- Bump http-types to 0.11+- Bump QuickCheck to 2.11+- Bump tasty to 1.0+- Bump tasty-hunit to 0.10+- Remove system-filepath dependency+- Embed feed templates rather than using data-files (contribution by Roman+ Kuznetsov)+- Fix pthread link error on GHC-8.2.2 (contribution by Shinya Yamaguchi)+- Extend capture with Regex handling (contribution by frederik-h)++## Hakyll 4.10.0.0++- Bump Pandoc to 2.0 (contribution by Vaibhav Sagar)+- Fix compression of calc() in CSS (contribution by Krzysztof Jurewicz)+- Make unixFilter output stderr when failing (contribution by Nick Boultbee)+- Export Check type from `Hakyll.Commands` (contribution by Futtetennista)+- Add overwritten files check to `hakyll-init` (contribution by Ilya Murzinov)+- Expose & document `hakyllWithExitCodeAndArgs`, `Options`, and `Command`+ (contribution by Michael Walker)+- Add check for non-overlapping redirects (contribution by gwern)+- Fix early exit when calling check as a library++## Hakyll 4.9.8.0++- Bump pandoc-citeproc to 0.10.5+- Bump optparse-applicative to 0.14+- Bump QuickCheck to 2.10+- Bump tasty-quickcheck to 0.9+- Restructure .cabal to avoid redundant compilation (contribution by+ Christopher League)++## Hakyll 4.9.7.0++- Fix compilation trouble with `Options.Applicative`+- Some small CSS compression improvements (contribution by Nicole Rauch)++## Hakyll 4.9.6.0++- Tighten dependency on `pandoc-citeproc` (contribution by Mikhail Glushenkov)+- Enable using a custom parser for command line arguments (contribution by+ Alberto)+- Update examples to semantic HTML (contribution by Elie Génard)+- Better error for `cached` on non-existing file+- Provide an `$allPages$` key when doing pagination+- Preserve file metadata in `copyFileCompiler` (contribution by frederik-h)++## Hakyll 4.9.5.1++- Bump blaze-html dependency to 0.9+- Bump blaze-markup dependency to 0.8+- Bump process dependency to 1.5++## Hakyll 4.9.5.0++- Fix compilation issue with `Hakyll.Check` if `checkExternal` is disabled+ (Fix by Magnus Therning)++## Hakyll 4.9.4.0++- Make `./site check` concurrent+- Bump directory dependency to 1.3+- Bump time dependency to 1.7+- Bump vector dependency to 0.12++## Hakyll 4.9.3.0++- Add a `Hakyll.Web.Redirect` module (contribution by gwern)+- Expose `Hakyll.Commands`+- Fix the exit code behaviour of `./site check`++## Hakyll 4.9.2.0++- Fix integer fields in YAML metadata (Fix by Nikolaos S. Papaspyrou)+- Bump pandoc dependency to 1.19++## Hakyll 4.9.1.0++- Allow optparse-applicative 0.13, QuickCheck 2.9, and pandoc 1.18+ (contributions by Chris Wong and Felix Yan)+- Fix extra test files for packaging source files (contribution by Julien+ Langlois)++## Hakyll 4.9.0.0++This release switches over some dependencies to alternatives, in order to clean+up some stuff and build on a wider variety of setups (stack/cabal).++- Move from `test-framework` to `tasty`+- Fix feed generator when item contains CDATA (contribution by Yann Esposito)+- Fix CompressCSS to not modify string constants (contribution by Nicole Rauch)+- Fix YAML dependency issue (contribution by Jens Peterson)+- Move from `cmdargs` to `optparse-applicative` (contribution by sk3r)+- Allow for trimming whitespace in templates (contribution by Sam Davis)+- Improve error messages for template parsing (contribution by Lorenzo+ Tabacchini)+- Improvements to the installation instructions (contribution by Thomas Koch)+- Move from `snap` to `warp` for preview server (contribution by Arguggi)+- Fix error in CompressCSS (contribution by Luca Molteni)+- Move example from XHTML to HTML5 (contribution by Peter Doherty)+- Make errors in check less verbose (contribution by Jan Tojnar)+- Work on building with GHC 8.0.1 (contribution by Rohan Jain)++## Hakyll 4.8.3.2++This release is compatible with GHC 8.0.1, although `previewServer` might not+work yet on some setups.++- Allow data-default 0.7, pandoc-citeproc 0.10, and tagsoup 0.14 (contributions+ by Paul van der Walt and Felix Yan)+- Allow binary 0.8, process 1.4, time 1.6 (contribution by Sergei Trofimovich)+- Fix issue with `.metadata` file reading++## Hakyll 4.8.3.1++- Bump scientific dependency to 0.3.4++## Hakyll 4.8.3.0++- Fix another compilation issue wrt. orphan `Show` instance from regex-tdfa+ (contribution by Sergei Trofimovich)++## Hakyll 4.8.2.0++- Fix compilation issue wrt. orphan `Show` instance from regex-tdfa++## Hakyll 4.8.1.0++- Fix compilation on windows++## Hakyll 4.8.0.1++- Fix issue with test suite++## Hakyll 4.8.0.0++- Support full YAML in page metadata+- Bump data-default dependency to 0.6+- Add snippet field for literal includes in templates (contribution by Nicolas+ Mattia)++## Hakyll 4.7.5.2++- Bump pandoc dependency to 1.17 (contribution by Felix Yan)+- Fix `unixFilter` documentation (contribution by Richard Cook)+- Bump example posts (contribution by Andrew Barchuk)+- Add a template compiler that only uses the template body (contribution by+ Bergi)++## Hakyll 4.7.5.1++- Bump pandoc and pandoc-citeproc dependencies to 1.16 and 0.9 respectively++## Hakyll 4.7.5.0++- Expose templating engine+- Fix bug in feed context precedence (contribution by Yuriy Syrovetskiy)+- Bump http-types dependency to 0.9++## Hakyll 4.7.4.0++- Expose `getItemModificationTime`++## Hakyll 4.7.3.1++- Bump pandoc-citeproc dependency to 0.8++## Hakyll 4.7.3.0++- Bump HUnit dependency to 1.3+- Add `poster` as an URL attribute (contribution by vtduncan)+- Prevent `hakyll-init` from generating directories with leading hyphen+ (contribution by Javran Cheng)++## Hakyll 4.7.2.3++- Fix time dependency in tests++## Hakyll 4.7.2.2++- Relax time dependency++## Hakyll 4.7.2.1++- Bump fsnotify dependency to 0.2++## Hakyll 4.7.2.0++- Improve documentation of `getResourceXXX` functions (contribution by Matthias+ C. M. Troffaes)+- Allow for empty templates+- Bump pandoc dependency to 1.15++## Hakyll 4.7.1.0++- Drop old-time, old-locale, time-locale-compat dependencies+- Add convenicence `pandocBiblioCompiler` (contribution by+ Matthias C. M. Troffaes)+- Add support for mediawiki (contribution by Chen Lei)++## Hakyll 4.7.0.0++- Bump pandoc to 1.14. This will break a lot of sites: since the pandoc parser+ might now return an error message, it is ran inside the `Compiler` monad where+ we can nicely handle the error.++## Hakyll 4.6.9.0++- Let caller decide exit (fix by Erik Dominikus)+- Bump pandoc-citeproc dependency++## Hakyll 4.6.8.1++- Fix test suite dependencies++## Hakyll 4.6.8.0++- Fix building on GHC 7.10 (fix by Charles Strahan)+- Add support for a custom teaser separator (contribution by Tom Sydney+ Kerckhove)+- Let Pandoc handle DocBook files (contribution by Joshua SImmons)++## Hakyll 4.6.7.1++- Bump dependencies++## Hakyll 4.6.7.0++- Bump dependencies+- Fix bug where hakyll-init would create a file called `name.cabal.cabal` (fix+ by Hans-Peter Deifel)++## Hakyll 4.6.6.0++- Fix compilation error when preview server is disabled (fix by Magnus Therning)+- Add author name by default to RSS feeds (contribution by Calen Pennington)++## Hakyll 4.6.5.0++- Bump dependencies+- Fix garbled "Listening on 0.0.0.0:8000" message+- Add `boolField` (contribution by Ferenc Wágner)++## Hakyll 4.6.4.0++- Fix another dependency handling bug when using snapshots+- Add `matchMetadata` for examining metadata when defining rules++## Hakyll 4.6.3.0++- Fix dependency handling bug++## Hakyll 4.6.2.0++- Loosen `binary` dependency+- Make dependency handling more granular so you can depend on specific snapshots+ of an item++## Hakyll 4.6.1.0++- Bump `fsnotify` and `pandoc-citeproc` dependencies+- Rewrite polling code a bit++## Hakyll 4.6.0.0++- Added `listFieldWith` function+- Improved `rulesExtraDependencies` behaviour+- Changed function syntax in templates from `$foo arg1 arg2$` to+ `$foo("arg1", "arg2")$`+- Support parsing date from directory names in addition to file names++## Hakyll 4.5.5.0++- Fix Binary instances for `pandoc` and `pandoc-citeproc`+- Fix `network-uri` dependency issue++## Hakyll 4.5.4.0++- Fix issue with HTML entities when running `withUrls` and `demoteHeaders`.+- Generate a cabal file for the initialised site.+- Add pagination support.++## Hakyll 4.5.3.0++- Bump Pandoc to 1.12.4 to include the org-mode reader.++## Hakyll 4.5.2.0++- Fix rebuilding everything issue with latest directory (contribution by Jorge+ Israel Peña)+- Fix issue with `toSiteRoot` (contribution by Izzy Cecil)+- Fix issue with tag dependencies, slightly improve caching++## Hakyll 4.5.0.0++- Fix issue with syntax highlighting and line numbers (contribution by Adelbert+ Chang)+- Improve documentation for `Context` (contribution by Daniil Frumin)+- Added `IsString` instance for `Template`+- Added the `pandocCompilerWithTransformM` function (contribution by Daniil+ Frumin)+- Make `./site check` return the right exit code (contribution by Andres Loeh)+- Use OS threads to make `./site watch` work nicely on Windows (contribution by+ Simonas Kazlauskas)+- Make the `unixFilter` function work better on windows by calling `shell`+ (contribution by Collin J. Doering)+- Add a command-line flag to bind on a user-specified host (contribution by+ chrisdotcode)++## Hakyll 4.4.3.0++- Fix issue when using `metadataRoute` after other custom routes++## Hakyll 4.4.2.0++- Fix issue where Hakyll would not detect a change if a `.metadata` file was+ deleted++## Hakyll 4.4.1.0++- Use Pandoc 1.12 highlighting by default++## Hakyll 4.4.0.0++- Update to work with Pandoc 1.12. This changes the type of `readPandocBibilio`:+ the `CSL` argument is no longer optional (contribution by Jorge Israel Peña)++- Fix incorrect output of `toSiteRoot` on windows (contribution by Saeid+ Al-Wazzan)++- Add a preview port option to `Configuration` (contribution by Jorge Israel+ Peña)++- Add `watch` command that polls for changes but does not necessarily launch a+ server (contribution by Eric Stolten)++- Generalise type of `metadataField`++- Fix issue where metadata was not correctly loaded when using versions++## Hakyll 4.3.3.0++- Re-add the `functionField` function++## Hakyll 4.3.2.0++- Re-add the `mapContext` function++- Unescape internal URLs when using `./site check` (contribution by Marc-Antoine+ Perennou)++## Hakyll 4.3.1.0++- Make teasers undefined if no `<!--more-->` comment is found++- Sanitize tag URLs (contribution by Simonas Kazlauskas)++## Hakyll 4.3.0.0++- Add conditionals, partials and for loops to the template system (includes a+ contribution by Ivan N. Veselov)++- Improvements to the preview functionality on windows (contribution by Jorge+ Israel Peña)++- Add pagination support (contribution by Anton Dubovik)++- Slight speedup for the Hakyll cache (contribution by justnoxx)++- Add teaser functionality (contribution by Ivan N. Veselov)++- Make `./site check` work with scheme-relative URLs (contribution by Simonas+ Kazlauskas)++- The `./site deploy` command can now be customized with Haskell code+ (contribution by Samuel Tardieu)++- Use `hsnotify` for proper polling instead of sleep loop on all platforms+ (contribution by Simonas Kazlauskas)++- More useful debug info available++## Hakyll 4.2.2.0++- Fix issue with `Alternative` instance of `Compiler`++## Hakyll 4.2.1.1++*March 9, 2013*++- Make `http-conduit` dependency optional by adding a `checkExternal` cabal flag++## Hakyll 4.2.1.0++*March 7, 2013*++- Fix issue where `copyFileCompiler` ignored `providerDirectory`++## Hakyll 4.2.0.0++*March 7, 2013*++- Read second extension for `.lhs`, e.g. `.md.lhs` or `.tex.lhs` (contribution+ by Alexander Vershilov)++- Speedup initialization by using modification times instead of hashing files++- Speedup initialization with a rewritten resource provider++- Fix `./site check` not working with sites that require a user agent (e.g.+ <http://www.wikipedia.org/>)++- Change `chronological` and `recentFirst` to actually look at the dates of+ items. This changes their types from:++ chronological, recentFirst :: [Item a] -> [Item a]++ to:++ chronological, recentFirst+ :: MonadMetadata m => [Item a] -> m [Item a]++ (contribution by Simonas Kazlauskas)++- Add `metadataRoute`, so it is now possible to use metadata when determining+ routes++- Improve metadata parser for multiline metadata fields (contribution by Peter+ Jones)++- Add the `getMetadataField` utility++## Hakyll 4.1.4.0++*January 26, 2013*++- Export the flexible `renderTags` function++## Hakyll 4.1.3.0++*January 26, 2013*++- Export the constructor of the `Tags` datatype++## Hakyll 4.1.2.0++*January 20, 2013*++- Fix an issue where a dependency cycle would lead to infinite recursion/stack+ overflow++## Hakyll 4.1.1.0++*January 20, 2013*++- Fix an issue regarding `relativizeUrls` expanding `<meta />` to+ `<meta></meta>`++## Hakyll 4.1.0.0++*January 20, 2013*++Update to use Pandoc 1.10, this requires changes to your `site.hs` if you're+using custom Pandoc options or the `Hakyll.Web.Pandoc.Biblio` module.++- `defaultHakyllParserState` renamed to `defaultHakyllReaderOptions`++- The type of `readPandocBiblio` changed++Because of the many changes, this release is no longer compatible with Pandoc+1.9.++## Hakyll 4.0.0.0++*January 16, 2013*++The Initial release of Hakyll 4, see+[this blogpost](http://jaspervdj.be/posts/2013-01-16-hakyll-4.0.html) and+[the migration guide](/tutorials/hakyll-3-to-hakyll4-migration-guide.html) for+an overview of changes.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Jasper Van der Jeugt+Copyright (c) 2009 - 2017, Jasper Van der Jeugt All rights reserved.
data/example/css/default.css view
@@ -1,56 +1,141 @@-body {- color: black;- font-size: 16px;- margin: 0px auto 0px auto;- width: 600px;+html {+ font-size: 62.5%; } -div#header {- border-bottom: 2px solid black;- margin-bottom: 30px;- padding: 12px 0px 12px 0px;+body {+ font-size: 1.6rem;+ color: #000; } -div#logo a {- color: black;- float: left;- font-size: 18px;- font-weight: bold;- text-decoration: none;+header {+ border-bottom: 0.2rem solid #000; } -div#header #navigation {- text-align: right;+nav {+ text-align: right; } -div#header #navigation a {- color: black;- font-size: 18px;- font-weight: bold;- margin-left: 12px;- text-decoration: none;- text-transform: uppercase;+nav a {+ font-size: 1.8rem;+ font-weight: bold;+ color: black;+ text-decoration: none;+ text-transform: uppercase; } -div#footer {- border-top: solid 2px black;- color: #555;- font-size: 12px;- margin-top: 30px;- padding: 12px 0px 12px 0px;- text-align: right;+footer {+ margin-top: 3rem;+ padding: 1.2rem 0;+ border-top: 0.2rem solid #000;+ font-size: 1.2rem;+ color: #555; } h1 {- font-size: 24px;+ font-size: 2.4rem; } h2 {- font-size: 20px;+ font-size: 2rem; } -div.info {- color: #555;- font-size: 14px;- font-style: italic;+article .header {+ font-size: 1.4rem;+ font-style: italic;+ color: #555;+}++.logo a {+ font-weight: bold;+ color: #000;+ text-decoration: none;+}++@media (max-width: 319px) {+ body {+ width: 90%;+ margin: 0;+ padding: 0 5%;+ }+ header {+ margin: 4.2rem 0;+ }+ nav {+ margin: 0 auto 3rem;+ text-align: center;+ }+ footer {+ text-align: center;+ }+ .logo {+ text-align: center;+ margin: 1rem auto 3rem;+ }+ .logo a {+ font-size: 2.4rem;+ }+ nav a {+ display: block;+ line-height: 1.6;+ }+}++@media (min-width: 320px) {+ body {+ width: 90%;+ margin: 0;+ padding: 0 5%;+ }+ header {+ margin: 4.2rem 0;+ }+ nav {+ margin: 0 auto 3rem;+ text-align: center;+ }+ footer {+ text-align: center;+ }+ .logo {+ text-align: center;+ margin: 1rem auto 3rem;+ }+ .logo a {+ font-size: 2.4rem;+ }+ nav a {+ display: inline;+ margin: 0 0.6rem;+ }+}++@media (min-width: 640px) {+ body {+ width: 60rem;+ margin: 0 auto;+ padding: 0;+ }+ header {+ margin: 0 0 3rem;+ padding: 1.2rem 0;+ }+ nav {+ margin: 0;+ text-align: right;+ }+ nav a {+ margin: 0 0 0 1.2rem;+ display: inline;+ }+ footer {+ text-align: right;+ }+ .logo {+ margin: 0;+ text-align: left;+ }+ .logo a {+ float: left;+ font-size: 1.8rem;+ } }
data/example/site.hs view
@@ -49,7 +49,6 @@ posts <- recentFirst =<< loadAll "posts/*" let indexCtx = listField "posts" postCtx (return posts) `mappend`- constField "title" "Home" `mappend` defaultContext getResourceBody
data/example/templates/default.html view
@@ -1,33 +1,33 @@-<?xml version="1.0" encoding="UTF-8"?>-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"-"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">+<!doctype html>+<html lang="en"> <head>- <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />+ <meta charset="utf-8">+ <meta http-equiv="x-ua-compatible" content="ie=edge">+ <meta name="viewport" content="width=device-width, initial-scale=1"> <title>My Hakyll Blog - $title$</title>- <link rel="stylesheet" type="text/css" href="/css/default.css" />+ <link rel="stylesheet" href="/css/default.css" /> </head> <body>- <div id="header">- <div id="logo">+ <header>+ <div class="logo"> <a href="/">My Hakyll Blog</a> </div>- <div id="navigation">+ <nav> <a href="/">Home</a> <a href="/about.html">About</a> <a href="/contact.html">Contact</a> <a href="/archive.html">Archive</a>- </div>- </div>+ </nav>+ </header> - <div id="content">+ <main role="main"> <h1>$title$</h1>- $body$- </div>- <div id="footer">+ </main>++ <footer> Site proudly generated by <a href="http://jaspervdj.be/hakyll">Hakyll</a>- </div>+ </footer> </body> </html>
data/example/templates/post.html view
@@ -1,8 +1,11 @@-<div class="info">- Posted on $date$- $if(author)$- by $author$- $endif$-</div>--$body$+<article>+ <section class="header">+ Posted on $date$+ $if(author)$+ by $author$+ $endif$+ </section>+ <section>+ $body$+ </section>+</article>
data/templates/atom.xml view
@@ -1,12 +1,15 @@ <?xml version="1.0" encoding="utf-8"?> <feed xmlns="http://www.w3.org/2005/Atom"> <title>$title$</title>+ <subtitle><![CDATA[$description$]]></subtitle> <link href="$root$$url$" rel="self" /> <link href="$root$" /> <id>$root$$url$</id> <author> <name>$authorName$</name>+ $if(authorEmail)$ <email>$authorEmail$</email>+ $endif$ </author> <updated>$updated$</updated> $body$
+ data/templates/feed-item.json view
@@ -0,0 +1,8 @@+{+ "id": "$root$$url$",+ "url": "$root$$url$",+ "content_html": "$description$",+ "title": "$title$",+ "date_published": "$published$",+ "date_modified": "$updated$"+}
+ data/templates/feed.json view
@@ -0,0 +1,18 @@+{+ "version": "https://www.jsonfeed.org/version/1.1",+ "title": "$title$",+ "description": "$description$",+ "home_page_url": "$root$",+ "feed_url": "$root$$url$",+ $if(authorName)$+ "authors": [+ {+ "name": "$authorName$"+ $if(authorEmail)$+ , "url": "mailto:$authorEmail$"+ $endif$+ }+ ],+ $endif$+ "items": [ $body$ ]+}
hakyll.cabal view
@@ -1,5 +1,5 @@ Name: hakyll-Version: 4.8.3.2+Version: 4.17.0.0 Synopsis: A static website compiler library Description:@@ -22,7 +22,7 @@ . - * An IRC channel, @#hakyll@ on freenode+ * An IRC channel, @#hakyll@ on irc.libera.chat (we *do not* have a channel on Freenode anymore) . @@ -37,7 +37,7 @@ License-File: LICENSE Category: Web -Cabal-Version: >= 1.8+Cabal-Version: >= 1.10 Build-Type: Simple Data-Dir: data @@ -56,53 +56,103 @@ example/index.html example/about.rst example/contact.markdown- templates/atom-item.xml- templates/atom.xml- templates/rss-item.xml- templates/rss.xml Extra-source-files:+ CHANGELOG.md+ tests/data/biblio/chicago.csl+ tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden+ tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden+ tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden+ tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden+ tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden+ tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden+ tests/data/biblio/cites-multiple.markdown+ tests/data/biblio/default.html+ tests/data/biblio/page.markdown+ tests/data/biblio/refs.bib+ tests/data/biblio/refs.yaml+ tests/data/biblio/refs2.yaml+ tests/data/embed.html tests/data/example.md tests/data/example.md.metadata tests/data/images/favicon.ico+ tests/data/just-meta.html+ tests/data/just-meta.html.out+ tests/data/partial-helper.html+ tests/data/partial.html+ tests/data/partial.html.out tests/data/posts/2010-08-26-birthday.md+ tests/data/posts/2018-09-26.md+ tests/data/posts/2019/05/10/tomorrow.md tests/data/russian.md+ tests/data/strip.html+ tests/data/strip.html.out+ tests/data/template-empty.html tests/data/template.html tests/data/template.html.out+ data/templates/atom-item.xml+ data/templates/atom.xml+ data/templates/rss-item.xml+ data/templates/rss.xml+ data/templates/feed.json+ data/templates/feed-item.json Source-Repository head Type: git- Location: git://github.com/jaspervdj/hakyll.git+ Location: https://github.com/jaspervdj/hakyll.git Flag previewServer Description: Include the preview server Default: True+ Manual: True Flag watchServer Description: Include the watch server Default: True+ Manual: True Flag checkExternal Description: Include external link checking Default: True+ Manual: True +Flag buildWebsite+ Description: Build the hakyll website+ Default: False+ Manual: True++Flag usePandoc+ Description: Include Pandoc support+ Default: True+ Manual: True+ Library- Ghc-Options: -Wall- Hs-Source-Dirs: src+ Ghc-Options: -Wall+ Hs-Source-Dirs: lib+ Default-language: Haskell2010 Exposed-Modules: Hakyll+ Hakyll.Commands Hakyll.Core.Compiler+ Hakyll.Core.Compiler.Internal Hakyll.Core.Configuration Hakyll.Core.Dependencies Hakyll.Core.File Hakyll.Core.Identifier Hakyll.Core.Identifier.Pattern Hakyll.Core.Item+ Hakyll.Core.Logger Hakyll.Core.Metadata+ Hakyll.Core.Provider+ Hakyll.Core.Provider.Metadata Hakyll.Core.Routes Hakyll.Core.Rules+ Hakyll.Core.Rules.Internal+ Hakyll.Core.Runtime+ Hakyll.Core.Store Hakyll.Core.UnixFilter+ Hakyll.Core.Util.File Hakyll.Core.Util.String Hakyll.Core.Writable Hakyll.Main@@ -110,77 +160,71 @@ Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls- Hakyll.Web.Pandoc- Hakyll.Web.Pandoc.Biblio- Hakyll.Web.Pandoc.FileType- Hakyll.Web.Tags+ Hakyll.Web.Meta.JSONLD+ Hakyll.Web.Meta.OpenGraph+ Hakyll.Web.Meta.TwitterCard Hakyll.Web.Paginate+ Hakyll.Web.Redirect+ Hakyll.Web.Tags Hakyll.Web.Template- Hakyll.Web.Template.Internal Hakyll.Web.Template.Context+ Hakyll.Web.Template.Internal+ Hakyll.Web.Template.Internal.Element+ Hakyll.Web.Template.Internal.Trim Hakyll.Web.Template.List Other-Modules: Data.List.Extended Data.Yaml.Extended Hakyll.Check- Hakyll.Commands- Hakyll.Core.Compiler.Internal Hakyll.Core.Compiler.Require+ Hakyll.Core.Identifier.Pattern.Internal Hakyll.Core.Item.SomeItem- Hakyll.Core.Logger- Hakyll.Core.Provider Hakyll.Core.Provider.Internal- Hakyll.Core.Provider.Metadata Hakyll.Core.Provider.MetadataCache- Hakyll.Core.Rules.Internal- Hakyll.Core.Runtime- Hakyll.Core.Store- Hakyll.Core.Util.File Hakyll.Core.Util.Parser- Hakyll.Web.Pandoc.Binary Paths_hakyll Build-Depends:- base >= 4.8 && < 5,- binary >= 0.5 && < 0.9,- blaze-html >= 0.5 && < 0.9,- blaze-markup >= 0.5.1 && < 0.8,- bytestring >= 0.9 && < 0.11,- cmdargs >= 0.10 && < 0.11,- containers >= 0.3 && < 0.6,- cryptohash >= 0.7 && < 0.12,- data-default >= 0.4 && < 0.8,- deepseq >= 1.3 && < 1.5,- directory >= 1.0 && < 1.3,- filepath >= 1.0 && < 1.5,- lrucache >= 1.1.1 && < 1.3,- mtl >= 1 && < 2.3,- network >= 2.6 && < 2.7,- network-uri >= 2.6 && < 2.7,- pandoc >= 1.14 && < 1.18,- pandoc-citeproc >= 0.4 && < 0.11,- parsec >= 3.0 && < 3.2,- process >= 1.0 && < 1.5,- random >= 1.0 && < 1.2,- regex-base >= 0.93 && < 0.94,- regex-tdfa >= 1.1 && < 1.3,- resourcet >= 1.1 && < 1.2,- scientific >= 0.3.4 && < 0.4,- tagsoup >= 0.13.1 && < 0.15,- text >= 0.11 && < 1.3,- time >= 1.4 && < 1.7,- time-locale-compat >= 0.1 && < 0.2,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.11 && < 0.12,- yaml >= 0.8 && < 0.9+ aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3,+ base >= 4.12 && < 5,+ binary >= 0.5 && < 0.10,+ blaze-html >= 0.5 && < 0.10,+ bytestring >= 0.9 && < 0.13,+ containers >= 0.3 && < 0.9,+ contravariant >= 1.5 && < 1.6,+ data-default >= 0.4 && < 0.9,+ deepseq >= 1.3 && < 1.6,+ directory >= 1.2.7.0 && < 1.4,+ file-embed >= 0.0.10.1 && < 0.0.17,+ filepath >= 1.0 && < 1.6,+ hashable >= 1.0 && < 2,+ lrucache >= 1.1.1 && < 1.3,+ mtl >= 1 && < 2.4,+ network-uri >= 2.6 && < 2.7,+ optparse-applicative >= 0.12 && < 0.20,+ parsec >= 3.0 && < 3.2,+ process >= 1.6 && < 1.7,+ random >= 1.0 && < 1.4,+ regex-tdfa >= 1.1 && < 1.4,+ resourcet >= 1.1 && < 1.4,+ scientific >= 0.3.4 && < 0.4,+ tagsoup >= 0.13.1 && < 0.15,+ template-haskell >= 2.14 && < 2.25,+ text >= 0.11 && < 1.3 || >= 2.0 && < 2.2,+ time >= 1.8 && < 1.16,+ time-locale-compat >= 0.1 && < 0.2,+ vector >= 0.11 && < 0.14,+ wai-app-static >= 3.1 && < 3.3,+ yaml >= 0.8.11 && < 0.12,+ xml-conduit >= 1.0 && < 1.11 If flag(previewServer) Build-depends:- snap-core >= 0.6 && < 0.10,- snap-server >= 0.6 && < 0.10,- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5+ wai >= 3.2 && < 3.3,+ warp >= 3.2 && < 3.5,+ http-types >= 0.9 && < 0.13,+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules:@@ -189,8 +233,7 @@ If flag(watchServer) Build-depends:- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DWATCH_SERVER Other-modules:@@ -198,16 +241,34 @@ If flag(checkExternal) Build-depends:- http-conduit >= 2.1 && < 2.2,- http-types >= 0.7 && < 0.10+ http-conduit >= 2.2 && < 2.4,+ http-types >= 0.7 && < 0.13 Cpp-options: -DCHECK_EXTERNAL + If flag(usePandoc)+ Exposed-Modules:+ Hakyll.Web.Pandoc+ Hakyll.Web.Pandoc.Biblio+ Hakyll.Web.Pandoc.FileType+ Other-Modules:+ Hakyll.Web.Pandoc.Binary+ Build-Depends:+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24+ Cpp-options:+ -DUSE_PANDOC+ Test-suite hakyll-tests- Type: exitcode-stdio-1.0- Hs-source-dirs: src tests- Main-is: TestSuite.hs- Ghc-options: -Wall+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: TestSuite.hs+ -- Note that tests are purposefully run without+ -- -threaded because of their side-effects. Test+ -- failures became apparent with tasty-1.5.4+ Ghc-options: -Wall+ Default-language: Haskell2010+ Other-modules: Hakyll.Core.Dependencies.Tests Hakyll.Core.Identifier.Tests@@ -219,91 +280,84 @@ Hakyll.Core.Store.Tests Hakyll.Core.UnixFilter.Tests Hakyll.Core.Util.String.Tests+ Hakyll.Web.CompressCss.Tests Hakyll.Web.Html.RelativizeUrls.Tests Hakyll.Web.Html.Tests- Hakyll.Web.Pandoc.FileType.Tests+ Hakyll.Web.Tags.Tests Hakyll.Web.Template.Context.Tests Hakyll.Web.Template.Tests+ Hakyll.Web.Feed.Tests TestSuite.Util Build-Depends:- HUnit >= 1.2 && < 1.4,- QuickCheck >= 2.4 && < 2.9,- test-framework >= 0.4 && < 0.9,- test-framework-hunit >= 0.3 && < 0.4,- test-framework-quickcheck2 >= 0.3 && < 0.4,+ hakyll,+ QuickCheck >= 2.8 && < 2.19,+ tasty >= 0.11 && < 1.6,+ tasty-golden >= 2.3 && < 2.4,+ tasty-hunit >= 0.9 && < 0.11,+ tasty-quickcheck >= 0.8 && < 0.12, -- Copy pasted from hakyll dependencies:- base >= 4.8 && < 5,- binary >= 0.5 && < 0.9,- blaze-html >= 0.5 && < 0.9,- blaze-markup >= 0.5.1 && < 0.8,- bytestring >= 0.9 && < 0.11,- cmdargs >= 0.10 && < 0.11,- containers >= 0.3 && < 0.6,- cryptohash >= 0.7 && < 0.12,- data-default >= 0.4 && < 0.8,- deepseq >= 1.3 && < 1.5,- directory >= 1.0 && < 1.3,- filepath >= 1.0 && < 1.5,- lrucache >= 1.1.1 && < 1.3,- mtl >= 1 && < 2.3,- network >= 2.6 && < 2.7,- network-uri >= 2.6 && < 2.7,- pandoc >= 1.14 && < 1.18,- pandoc-citeproc >= 0.4 && < 0.11,- parsec >= 3.0 && < 3.2,- process >= 1.0 && < 1.5,- random >= 1.0 && < 1.2,- regex-base >= 0.93 && < 0.94,- regex-tdfa >= 1.1 && < 1.3,- resourcet >= 1.1 && < 1.2,- scientific >= 0.3.4 && < 0.4,- tagsoup >= 0.13.1 && < 0.15,- text >= 0.11 && < 1.3,- time >= 1.4 && < 1.7,- time-locale-compat >= 0.1 && < 0.2,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.11 && < 0.12,- yaml >= 0.8 && < 0.9+ aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3,+ base >= 4.12 && < 5,+ bytestring >= 0.9 && < 0.13,+ containers >= 0.3 && < 0.9,+ filepath >= 1.0 && < 1.6,+ tagsoup >= 0.13.1 && < 0.15,+ yaml >= 0.8.11 && < 0.12 If flag(previewServer)- Build-depends:- snap-core >= 0.6 && < 0.10,- snap-server >= 0.6 && < 0.10,- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER- Other-modules:- Hakyll.Preview.Poll- Hakyll.Preview.Server If flag(watchServer)- Build-depends:- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER- Other-modules:- Hakyll.Preview.Poll If flag(checkExternal)- Build-depends:- http-conduit >= 2.1 && < 2.2,- http-types >= 0.7 && < 0.10 Cpp-options: -DCHECK_EXTERNAL -Executable hakyll-init- Ghc-options: -Wall- Hs-source-dirs: src- Main-is: Hakyll/Init.hs+ If flag(usePandoc)+ Other-modules:+ Hakyll.Web.Pandoc.Biblio.Tests+ Hakyll.Web.Pandoc.FileType.Tests+ Cpp-options:+ -DUSE_PANDOC+ Build-Depends:+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24 - Build-depends:- base >= 4 && < 5,- directory >= 1.0 && < 1.3,- filepath >= 1.0 && < 1.5 +Executable hakyll-init+ Main-is: Init.hs+ Ghc-options: -Wall -threaded+ Hs-source-dirs: src+ Default-language: Haskell2010+ Other-modules:- Hakyll.Core.Util.File Paths_hakyll++ Build-depends:+ hakyll,+ base >= 4.12 && < 5,+ directory >= 1.0 && < 1.4,+ filepath >= 1.0 && < 1.6++Executable hakyll-website+ Main-is: site.hs+ Ghc-options: -Wall -threaded+ Hs-source-dirs: web+ Default-language: Haskell2010++ If flag(buildWebsite)+ Buildable: True+ Else+ Buildable: False++ Build-depends:+ hakyll,+ base >= 4.12 && < 5,+ directory >= 1.0 && < 1.4,+ filepath >= 1.0 && < 1.6,+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24
+ lib/Data/List/Extended.hs view
@@ -0,0 +1,15 @@+module Data.List.Extended+ ( module Data.List+ , breakWhen+ ) where++import Data.List++-- | Like 'break', but can act on the entire tail of the list.+breakWhen :: ([a] -> Bool) -> [a] -> ([a], [a])+breakWhen predicate = go []+ where+ go buf [] = (reverse buf, [])+ go buf (x : xs)+ | predicate (x : xs) = (reverse buf, x : xs)+ | otherwise = go (x : buf) xs
+ lib/Data/Yaml/Extended.hs view
@@ -0,0 +1,24 @@+module Data.Yaml.Extended+ ( module Data.Yaml+ , toString+ , toList+ ) where++import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Yaml+import Data.Scientific++toString :: Value -> Maybe String+toString (String t) = Just (T.unpack t)+toString (Bool True) = Just "true"+toString (Bool False) = Just "false"+-- | Make sure that numeric fields containing integer numbers are shown as+-- | integers (i.e., "42" instead of "42.0").+toString (Number d) | isInteger d = Just (formatScientific Fixed (Just 0) d)+ | otherwise = Just (show d)+toString _ = Nothing++toList :: Value -> Maybe [Value]+toList (Array a) = Just (V.toList a)+toList _ = Nothing
+ lib/Hakyll.hs view
@@ -0,0 +1,72 @@+--------------------------------------------------------------------------------+-- | Top-level module exporting all modules that are interesting for the user+{-# LANGUAGE CPP #-}+module Hakyll+ ( module Hakyll.Core.Compiler+ , module Hakyll.Core.Configuration+ , module Hakyll.Core.File+ , module Hakyll.Core.Identifier+ , module Hakyll.Core.Identifier.Pattern+ , module Hakyll.Core.Item+ , module Hakyll.Core.Metadata+ , module Hakyll.Core.Routes+ , module Hakyll.Core.Rules+ , module Hakyll.Core.UnixFilter+ , module Hakyll.Core.Util.File+ , module Hakyll.Core.Util.String+ , module Hakyll.Core.Writable+ , module Hakyll.Main+ , module Hakyll.Web.CompressCss+ , module Hakyll.Web.Feed+ , module Hakyll.Web.Html+ , module Hakyll.Web.Html.RelativizeUrls+ , module Hakyll.Web.Meta.JSONLD+ , module Hakyll.Web.Meta.OpenGraph+ , module Hakyll.Web.Meta.TwitterCard+ , module Hakyll.Web.Paginate+#ifdef USE_PANDOC+ , module Hakyll.Web.Pandoc+ , module Hakyll.Web.Pandoc.Biblio+ , module Hakyll.Web.Pandoc.FileType+#endif+ , module Hakyll.Web.Redirect+ , module Hakyll.Web.Tags+ , module Hakyll.Web.Template+ , module Hakyll.Web.Template.Context+ , module Hakyll.Web.Template.List+ ) where+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Configuration+import Hakyll.Core.File+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Core.Routes+import Hakyll.Core.Rules+import Hakyll.Core.UnixFilter+import Hakyll.Core.Util.File+import Hakyll.Core.Util.String+import Hakyll.Core.Writable+import Hakyll.Main+import Hakyll.Web.CompressCss+import Hakyll.Web.Feed+import Hakyll.Web.Html+import Hakyll.Web.Html.RelativizeUrls+import Hakyll.Web.Meta.JSONLD+import Hakyll.Web.Meta.OpenGraph+import Hakyll.Web.Meta.TwitterCard+import Hakyll.Web.Paginate+#ifdef USE_PANDOC+import Hakyll.Web.Pandoc+import Hakyll.Web.Pandoc.Biblio+import Hakyll.Web.Pandoc.FileType+#endif+import Hakyll.Web.Redirect+import Hakyll.Web.Tags+import Hakyll.Web.Template+import Hakyll.Web.Template.Context+import Hakyll.Web.Template.List
+ lib/Hakyll/Check.hs view
@@ -0,0 +1,294 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Check+ ( Check (..)+ , check+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,+ readMVar)+import Control.Exception (SomeAsyncException (..),+ SomeException (..), throw, try)+import Control.Monad (foldM, forM_)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State (StateT, get, modify, runStateT)+import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Resource (runResourceT)+import Data.List (isPrefixOf)+import qualified Data.Map.Lazy as Map+import Network.URI (unEscapeString)+import System.Directory (doesDirectoryExist,+ doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, (</>))+import qualified Text.HTML.TagSoup as TS+++--------------------------------------------------------------------------------+#ifdef CHECK_EXTERNAL+import Data.List (intercalate)+import Data.Typeable (cast)+import Data.Version (versionBranch)+import GHC.Exts (fromString)+import qualified Network.HTTP.Conduit as Http+import qualified Network.HTTP.Types as Http+import qualified Paths_hakyll as Paths_hakyll+#endif+++--------------------------------------------------------------------------------+import Hakyll.Core.Configuration+import Hakyll.Core.Logger (Logger)+import qualified Hakyll.Core.Logger as Logger+import Hakyll.Core.Util.File+import Hakyll.Web.Html+++--------------------------------------------------------------------------------+data Check = All | InternalLinks+ deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+check :: Configuration -> Logger -> Check -> IO ExitCode+check config logger check' = do+ ((), state) <- runChecker checkDestination config logger check'+ failed <- countFailedLinks state+ return $ if failed > 0 then ExitFailure 1 else ExitSuccess+++--------------------------------------------------------------------------------+countFailedLinks :: CheckerState -> IO Int+countFailedLinks state = foldM addIfFailure 0 (Map.elems state)+ where addIfFailure failures mvar = do+ checkerWrite <- readMVar mvar+ return $ failures + checkerFaulty checkerWrite+++--------------------------------------------------------------------------------+data CheckerRead = CheckerRead+ { checkerConfig :: Configuration+ , checkerLogger :: Logger+ , checkerCheck :: Check+ }+++--------------------------------------------------------------------------------+data CheckerWrite = CheckerWrite+ { checkerFaulty :: Int+ , checkerOk :: Int+ } deriving (Show)+++--------------------------------------------------------------------------------+instance Semigroup CheckerWrite where+ (<>) (CheckerWrite f1 o1) (CheckerWrite f2 o2) =+ CheckerWrite (f1 + f2) (o1 + o2)++instance Monoid CheckerWrite where+ mempty = CheckerWrite 0 0+ mappend = (<>)+++--------------------------------------------------------------------------------+type CheckerState = Map.Map URL (MVar CheckerWrite)+++--------------------------------------------------------------------------------+type Checker a = ReaderT CheckerRead (StateT CheckerState IO) a+++--------------------------------------------------------------------------------+type URL = String+++--------------------------------------------------------------------------------+runChecker :: Checker a -> Configuration -> Logger -> Check+ -> IO (a, CheckerState)+runChecker checker config logger check' = do+ let read' = CheckerRead+ { checkerConfig = config+ , checkerLogger = logger+ , checkerCheck = check'+ }+ Logger.flush logger+ runStateT (runReaderT checker read') Map.empty+++--------------------------------------------------------------------------------+checkDestination :: Checker ()+checkDestination = do+ config <- checkerConfig <$> ask+ files <- liftIO $ getRecursiveContents+ (const $ return False) (destinationDirectory config)++ let htmls =+ [ destinationDirectory config </> file+ | file <- files+ , checkHtmlFile config file+ ]++ forM_ htmls checkFile+++--------------------------------------------------------------------------------+checkFile :: FilePath -> Checker ()+checkFile filePath = do+ logger <- checkerLogger <$> ask+ contents <- liftIO $ readFile filePath+ Logger.header logger $ "Checking file " ++ filePath++ let urls = getUrls $ TS.parseTags contents+ forM_ urls $ \url -> do+ Logger.debug logger $ "Checking link " ++ url+ m <- liftIO newEmptyMVar+ checkUrlIfNeeded filePath (canonicalizeUrl url) m+ where+ -- Check scheme-relative links+ canonicalizeUrl url = if schemeRelative url then "http:" ++ url else url+ schemeRelative = isPrefixOf "//"+++--------------------------------------------------------------------------------+checkUrlIfNeeded :: FilePath -> URL -> MVar CheckerWrite -> Checker ()+checkUrlIfNeeded filepath url m = do+ logger <- checkerLogger <$> ask+ needsCheck <- (== All) . checkerCheck <$> ask+ checked <- (url `Map.member`) <$> get+ if not needsCheck || checked+ then Logger.debug logger "Already checked, skipping"+ else do modify $ Map.insert url m+ checkUrl filepath url+++--------------------------------------------------------------------------------+checkUrl :: FilePath -> URL -> Checker ()+checkUrl filePath url+ | isExternal url = checkExternalUrl url+ | hasProtocol url = skip url $ Just "Unknown protocol, skipping"+ | otherwise = checkInternalUrl filePath url+ where+ validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."+ hasProtocol str = case break (== ':') str of+ (proto, ':' : _) -> all (`elem` validProtoChars) proto+ _ -> False+++--------------------------------------------------------------------------------+ok :: URL -> Checker ()+ok url = putCheckResult url mempty {checkerOk = 1}+++--------------------------------------------------------------------------------+skip :: URL -> Maybe String -> Checker ()+skip url maybeReason = do+ logger <- checkerLogger <$> ask+ case maybeReason of+ Nothing -> return ()+ Just reason -> Logger.debug logger reason+ putCheckResult url mempty {checkerOk = 1}+++--------------------------------------------------------------------------------+faulty :: URL -> Maybe String -> Checker ()+faulty url reason = do+ logger <- checkerLogger <$> ask+ Logger.error logger $ "Broken link to " ++ show url ++ explanation+ putCheckResult url mempty {checkerFaulty = 1}+ where+ formatExplanation = (" (" ++) . (++ ")")+ explanation = maybe "" formatExplanation reason+++--------------------------------------------------------------------------------+putCheckResult :: URL -> CheckerWrite -> Checker ()+putCheckResult url result = do+ state <- get+ let maybeMVar = Map.lookup url state+ case maybeMVar of+ Just m -> liftIO $ putMVar m result+ Nothing -> do+ logger <- checkerLogger <$> ask+ Logger.debug logger "Failed to find existing entry for checked URL"+++--------------------------------------------------------------------------------+checkInternalUrl :: FilePath -> URL -> Checker ()+checkInternalUrl base url = case url' of+ "" -> ok url+ _ -> do+ config <- checkerConfig <$> ask+ let dest = destinationDirectory config+ dir = takeDirectory base+ filePath+ | "/" `isPrefixOf` url' = dest ++ url'+ | otherwise = dir </> url'++ exists <- checkFileExists filePath+ if exists then ok url else faulty url Nothing+ where+ url' = stripFragments $ unEscapeString url+++--------------------------------------------------------------------------------+checkExternalUrl :: URL -> Checker ()+#ifdef CHECK_EXTERNAL+checkExternalUrl url = do+ result <- requestExternalUrl url+ case result of+ Left (SomeException e) ->+ case (cast e :: Maybe SomeAsyncException) of+ Just ae -> throw ae+ _ -> faulty url (Just $ showException e)+ Right _ -> ok url+ where+ -- Convert exception to a concise form+ showException e = case cast e of+ Just (Http.HttpExceptionRequest _ e') -> show e'+ _ -> case words $ show e of+ w:_ -> w+ [] -> error "Hakyll.Check.checkExternalUrl: impossible"++requestExternalUrl :: URL -> Checker (Either SomeException Bool)+requestExternalUrl url = liftIO $ try $ do+ mgr <- Http.newManager Http.tlsManagerSettings+ runResourceT $ do+ request <- Http.parseRequest url+ response <- Http.http (settings request) mgr+ let code = Http.statusCode (Http.responseStatus response)+ -- Recall that 3XX status codes are redirections, which aren't necessarily errors. + return $ code >= 200 && code < 400+ where+ -- Add additional request info+ settings r = r+ { Http.method = "HEAD"+ , Http.redirectCount = 10+ , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r+ }++ -- Nice user agent info+ ua = fromString $ "hakyll-check/" +++ (intercalate "." $ map show $ versionBranch Paths_hakyll.version)+#else+checkExternalUrl url = skip url Nothing+#endif+++--------------------------------------------------------------------------------+-- | Wraps doesFileExist, also checks for index.html+checkFileExists :: FilePath -> Checker Bool+checkFileExists filePath = liftIO $ do+ file <- doesFileExist filePath+ dir <- doesDirectoryExist filePath+ case (file, dir) of+ (True, _) -> return True+ (_, True) -> doesFileExist $ filePath </> "index.html"+ _ -> return False+++--------------------------------------------------------------------------------+stripFragments :: String -> String+stripFragments = takeWhile (not . flip elem ['?', '#'])
+ lib/Hakyll/Commands.hs view
@@ -0,0 +1,170 @@+ --------------------------------------------------------------------------------+-- | Implementation of Hakyll commands: build, preview...+{-# LANGUAGE CPP #-}+module Hakyll.Commands+ ( Check(..)+ , build+ , check+ , clean+ , preview+ , rebuild+ , server+ , deploy+ , watch+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent+import System.Exit (ExitCode)+++--------------------------------------------------------------------------------+import Hakyll.Check (Check(..))+import qualified Hakyll.Check as Check+import Hakyll.Core.Configuration+import Hakyll.Core.Logger (Logger)+import qualified Hakyll.Core.Logger as Logger+import Hakyll.Core.Rules+import Hakyll.Core.Rules.Internal+import Hakyll.Core.Runtime+import Hakyll.Core.Util.File+++--------------------------------------------------------------------------------+#ifdef WATCH_SERVER+import Hakyll.Preview.Poll (watchUpdates)+#endif++#ifdef PREVIEW_SERVER+import Hakyll.Preview.Server+#endif++#ifdef mingw32_HOST_OS+import Control.Monad (void)+import System.IO.Error (catchIOError)+#endif+++--------------------------------------------------------------------------------+-- | Build the site+build :: RunMode -> Configuration -> Logger -> Rules a -> IO ExitCode+build mode conf logger rules = fst <$> run mode conf logger rules+++--------------------------------------------------------------------------------+-- | Run the checker and exit+check :: Configuration -> Logger -> Check.Check -> IO ExitCode+check = Check.check+++--------------------------------------------------------------------------------+-- | Remove the output directories+clean :: Configuration -> Logger -> IO ()+clean conf logger = do+ remove $ destinationDirectory conf+ remove $ storeDirectory conf+ remove $ tmpDirectory conf+ where+ remove dir = do+ Logger.header logger $ "Removing " ++ dir ++ "..."+ removeDirectory dir+++--------------------------------------------------------------------------------+-- | Preview the site+preview :: Configuration -> Logger -> Rules a -> Int -> IO ()+#ifdef PREVIEW_SERVER+preview conf logger rules port = do+ deprecatedMessage+ watch conf logger "0.0.0.0" port True rules+ where+ deprecatedMessage = mapM_ putStrLn [ "The preview command has been deprecated."+ , "Use the watch command for recompilation and serving."+ ]+#else+preview _ _ _ _ = previewServerDisabled+#endif+++--------------------------------------------------------------------------------+-- | Watch and recompile for changes++watch :: Configuration -> Logger -> String -> Int -> Bool -> Rules a -> IO ()+#ifdef WATCH_SERVER+watch conf logger host port runServer rules = do+#ifndef mingw32_HOST_OS+ _ <- forkIO $ watchUpdates conf update+#else+ -- Force windows users to compile with -threaded flag, as otherwise+ -- thread is blocked indefinitely.+ catchIOError (void $ forkOS $ watchUpdates conf update) $ \_ -> do+ fail $ "Hakyll.Commands.watch: Could not start update watching " +++ "thread. Did you compile with -threaded flag?"+#endif+ server'+ where+ update = do+ (_, ruleSet) <- run RunModeNormal conf logger rules+ return $ rulesPattern ruleSet+ loop = threadDelay 100000 >> loop+ server' = if runServer then server conf logger host port else loop+#else+watch _ _ _ _ _ _ = watchServerDisabled+#endif++--------------------------------------------------------------------------------+-- | Rebuild the site+rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode+rebuild conf logger rules =+ clean conf logger *> build RunModeNormal conf logger rules++--------------------------------------------------------------------------------+-- | Start a server+server :: Configuration -> Logger -> String -> Int -> IO ()+#ifdef PREVIEW_SERVER+server conf logger host port = do+ let settings = previewSettings conf $ destinationDirectory conf+ staticServer logger settings host port+#else+server _ _ _ _ = previewServerDisabled+#endif+++--------------------------------------------------------------------------------+-- | Upload the site+deploy :: Configuration -> IO ExitCode+deploy conf = deploySite conf conf+++--------------------------------------------------------------------------------+-- | Print a warning message about the preview serving not being enabled+#ifndef PREVIEW_SERVER+previewServerDisabled :: IO ()+previewServerDisabled = mapM_ putStrLn+ [ "PREVIEW SERVER"+ , ""+ , "The preview server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +previewServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ]+#endif++#ifndef WATCH_SERVER+watchServerDisabled :: IO ()+watchServerDisabled = mapM_ putStrLn+ [ "WATCH SERVER"+ , ""+ , "The watch server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +watchServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ]+#endif
+ lib/Hakyll/Core/Compiler.hs view
@@ -0,0 +1,232 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Hakyll.Core.Compiler+ ( Compiler+ , getUnderlying+ , getUnderlyingExtension+ , makeItem+ , getRoute+ , getResourceBody+ , getResourceString+ , getResourceLBS+ , getResourceFilePath++ , Internal.Snapshot+ , saveSnapshot+ , Internal.load+ , Internal.loadSnapshot+ , Internal.loadBody+ , Internal.loadSnapshotBody+ , Internal.loadAll+ , Internal.loadAllSnapshots++ , cached+ , recompilingUnsafeCompiler+ , unsafeCompiler+ , debugCompiler+ , noResult+ , withErrorMessage+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (unless, when, (>=>))+import Data.Binary (Binary)+import Data.ByteString.Lazy (ByteString)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Typeable (Typeable)+import System.Environment (getProgName)+import System.FilePath (takeExtension)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import qualified Hakyll.Core.Compiler.Require as Internal+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Item+import Hakyll.Core.Logger as Logger+import Hakyll.Core.Provider+import Hakyll.Core.Routes+import qualified Hakyll.Core.Store as Store+++--------------------------------------------------------------------------------+-- | Get the underlying identifier.+getUnderlying :: Compiler Identifier+getUnderlying = compilerUnderlying <$> compilerAsk+++--------------------------------------------------------------------------------+-- | Get the extension of the underlying identifier. Returns something like+-- @".html"@+getUnderlyingExtension :: Compiler String+getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying+++--------------------------------------------------------------------------------+-- | Create an item from the underlying identifier and a given value.+makeItem :: a -> Compiler (Item a)+makeItem x = do+ identifier <- getUnderlying+ return $ Item identifier x+++--------------------------------------------------------------------------------+-- | Get the route for a specified item+getRoute :: Identifier -> Compiler (Maybe FilePath)+getRoute identifier = do+ provider <- compilerProvider <$> compilerAsk+ routes <- compilerRoutes <$> compilerAsk+ -- Note that this makes us dependend on that identifier: when the metadata+ -- of that item changes, the route may change, hence we have to recompile+ (mfp, um) <- compilerUnsafeIO $ runRoutes routes provider identifier+ when um $ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier]+ return mfp+++--------------------------------------------------------------------------------+-- | Get the full contents of the matched source file as a string,+-- but without metadata preamble, if there was one.+getResourceBody :: Compiler (Item String)+getResourceBody = getResourceWith resourceBody+++--------------------------------------------------------------------------------+-- | Get the full contents of the matched source file as a string.+getResourceString :: Compiler (Item String)+getResourceString = getResourceWith resourceString+++--------------------------------------------------------------------------------+-- | Get the full contents of the matched source file as a lazy bytestring.+getResourceLBS :: Compiler (Item ByteString)+getResourceLBS = getResourceWith resourceLBS+++--------------------------------------------------------------------------------+-- | Get the file path of the resource we are compiling+getResourceFilePath :: Compiler FilePath+getResourceFilePath = do+ provider <- compilerProvider <$> compilerAsk+ id' <- compilerUnderlying <$> compilerAsk+ return $ resourceFilePath provider id'+++--------------------------------------------------------------------------------+-- | Overloadable function for 'getResourceString' and 'getResourceLBS'+getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a)+getResourceWith reader = do+ provider <- compilerProvider <$> compilerAsk+ id' <- compilerUnderlying <$> compilerAsk+ let filePath = toFilePath id'+ if resourceExists provider id'+ then compilerUnsafeIO $ Item id' <$> reader provider id'+ else fail $ error' filePath+ where+ error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " +++ show fp ++ " not found"+++--------------------------------------------------------------------------------+-- | Save a snapshot of the item. This function returns the same item, which+-- convenient for building '>>=' chains.+saveSnapshot :: (Binary a, Typeable a)+ => Internal.Snapshot -> Item a -> Compiler (Item a)+saveSnapshot snapshot item = do+ store <- compilerStore <$> compilerAsk+ logger <- compilerLogger <$> compilerAsk+ compilerUnsafeIO $ do+ Logger.debug logger $ "Storing snapshot: " ++ snapshot+ Internal.saveSnapshot store snapshot item++ -- Signal that we saved the snapshot.+ Compiler $ \_ -> return $ CompilerSnapshot snapshot (return item)+++--------------------------------------------------------------------------------+-- | Turn on caching for a compilation value to avoid recomputing it+-- on subsequent Hakyll runs.+-- The storage key consists of the underlying identifier of the compiled+-- ressource and the given name.+cached :: (Binary a, Typeable a)+ => String+ -> Compiler a+ -> Compiler a+cached name compiler = do+ id' <- compilerUnderlying <$> compilerAsk+ store <- compilerStore <$> compilerAsk+ provider <- compilerProvider <$> compilerAsk++ -- Give a better error message when the resource is not there at all.+ unless (resourceExists provider id') $ fail $ itDoesntEvenExist id'++ let modified = resourceModified provider id'+ k = [name, show id']+ go = compiler >>= \v -> v <$ compilerUnsafeIO (Store.set store k v)+ if modified+ then go+ else compilerUnsafeIO (Store.get store k) >>= \r -> case r of+ -- found: report cache hit and return value+ Store.Found v -> v <$ compilerTellCacheHits 1+ -- not found: unexpected, but recoverable+ Store.NotFound -> go+ -- other results: unrecoverable error+ _ -> fail . error' =<< compilerUnsafeIO getProgName+ where+ error' progName =+ "Hakyll.Core.Compiler.cached: Cache corrupt! " +++ "Try running: " ++ progName ++ " clean"++ itDoesntEvenExist id' =+ "Hakyll.Core.Compiler.cached: You are trying to (perhaps " +++ "indirectly) use `cached` on a non-existing resource: there " +++ "is no file backing " ++ show id'+++--------------------------------------------------------------------------------+-- | Run an IO computation without dependencies in a Compiler.+-- You probably want 'recompilingUnsafeCompiler' instead.+unsafeCompiler :: IO a -> Compiler a+unsafeCompiler = compilerUnsafeIO++--------------------------------------------------------------------------------+-- | Run an IO computation in a Compiler. Unlike 'unsafeCompiler',+-- this function will cause the item to be recompiled every time.+recompilingUnsafeCompiler :: IO a -> Compiler a+recompilingUnsafeCompiler io = Compiler $ \_ -> do+ a <- io+ pure $ CompilerDone a mempty { compilerDependencies = [AlwaysOutOfDate] }+++--------------------------------------------------------------------------------+-- | Fail so that it is treated as non-defined in an @\$if()\$@ branching+-- "Hakyll.Web.Template" macro, and alternative+-- 'Hakyll.Web.Template.Context.Context's are tried+--+-- @since 4.13.0+noResult :: String -> Compiler a+noResult = compilerNoResult . return+++--------------------------------------------------------------------------------+-- | Prepend an error line to the error, if there is one. This allows you to+-- add helpful context to error messages.+--+-- @since 4.13.0+withErrorMessage :: String -> Compiler a -> Compiler a+withErrorMessage x = do+ compilerTry >=> either (compilerResult . CompilerError . prepend) return+ where+ prepend (CompilationFailure es) = CompilationFailure (x `NonEmpty.cons` es)+ prepend (CompilationNoResult es) = CompilationNoResult (x : es)+++--------------------------------------------------------------------------------+-- | Compiler for debugging purposes.+-- Passes a message to the debug logger that is printed in verbose mode.+debugCompiler :: String -> Compiler ()+debugCompiler msg = do+ logger <- compilerLogger <$> compilerAsk+ compilerUnsafeIO $ Logger.debug logger msg
+ lib/Hakyll/Core/Compiler/Internal.hs view
@@ -0,0 +1,364 @@+--------------------------------------------------------------------------------+-- | Internally used compiler module+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Hakyll.Core.Compiler.Internal+ ( -- * Types+ Snapshot+ , CompilerRead (..)+ , CompilerWrite (..)+ , CompilerErrors (..)+ , CompilerResult (..)+ , Compiler (..)+ , runCompiler++ -- * Core operations+ , compilerResult+ , compilerTell+ , compilerAsk+ , compilerUnsafeIO++ -- * Error operations+ , compilerThrow+ , compilerNoResult+ , compilerCatch+ , compilerTry+ , compilerErrorMessages++ -- * Utilities+ , compilerDebugEntries+ , compilerTellDependencies+ , compilerTellCacheHits+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative (Alternative (..))+import Control.Exception (SomeException, handle)+import Control.Monad (forM, forM_)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Except (MonadError (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Set (Set)+import qualified Data.Set as S+++--------------------------------------------------------------------------------+import Hakyll.Core.Configuration+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import qualified Hakyll.Core.Logger as Logger+import Hakyll.Core.Metadata+import Hakyll.Core.Provider+import Hakyll.Core.Routes+import Hakyll.Core.Store+++--------------------------------------------------------------------------------+-- | Whilst compiling an item, it possible to save multiple snapshots of it, and+-- not just the final result.+type Snapshot = String+++--------------------------------------------------------------------------------+-- | Environment in which a compiler runs+data CompilerRead = CompilerRead+ { -- | Main configuration+ compilerConfig :: Configuration+ , -- | Underlying identifier+ compilerUnderlying :: Identifier+ , -- | Resource provider+ compilerProvider :: Provider+ , -- | List of all known identifiers+ compilerUniverse :: Set Identifier+ , -- | Site routes+ compilerRoutes :: Routes+ , -- | Compiler store+ compilerStore :: Store+ , -- | Logger+ compilerLogger :: Logger.Logger+ }+++--------------------------------------------------------------------------------+data CompilerWrite = CompilerWrite+ { compilerDependencies :: [Dependency]+ , compilerCacheHits :: Int+ } deriving (Show)+++--------------------------------------------------------------------------------+instance Semigroup CompilerWrite where+ (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) =+ CompilerWrite (d1 ++ d2) (h1 + h2)++instance Monoid CompilerWrite where+ mempty = CompilerWrite [] 0+ mappend = (<>)+++--------------------------------------------------------------------------------+-- | Distinguishes reasons in a 'CompilerError'+data CompilerErrors a+ -- | One or more exceptions occured during compilation+ = CompilationFailure (NonEmpty a)+ -- | Absence of any result, most notably in template contexts. May still+ -- have error messages.+ | CompilationNoResult [a]+ deriving Functor+++-- | Unwrap a `CompilerErrors`+compilerErrorMessages :: CompilerErrors a -> [a]+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x+compilerErrorMessages (CompilationNoResult x) = x+++--------------------------------------------------------------------------------+-- | An intermediate result of a compilation step+data CompilerResult a+ = CompilerDone a CompilerWrite+ | CompilerSnapshot Snapshot (Compiler a)+ | CompilerRequire [(Identifier, Snapshot)] (Compiler a)+ | CompilerError (CompilerErrors String)+++--------------------------------------------------------------------------------+-- | A monad which lets you compile items and takes care of dependency tracking+-- for you.+newtype Compiler a = Compiler+ { unCompiler :: CompilerRead -> IO (CompilerResult a)+ }+++--------------------------------------------------------------------------------+instance Functor Compiler where+ fmap f (Compiler c) = Compiler $ \r -> do+ res <- c r+ return $ case res of+ CompilerDone x w -> CompilerDone (f x) w+ CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')+ CompilerRequire i c' -> CompilerRequire i (fmap f c')+ CompilerError e -> CompilerError e+ {-# INLINE fmap #-}+++--------------------------------------------------------------------------------+instance Monad Compiler where+ return = pure+ {-# INLINE return #-}++ Compiler c >>= f = Compiler $ \r -> do+ res <- c r+ case res of+ CompilerDone x w -> do+ res' <- unCompiler (f x) r+ return $ case res' of+ CompilerDone y w' -> CompilerDone y (w `mappend` w')+ CompilerSnapshot s c' -> CompilerSnapshot s $ do+ compilerTell w -- Save dependencies!+ c'+ CompilerRequire i c' -> CompilerRequire i $ do+ compilerTell w -- Save dependencies!+ c'+ CompilerError e -> CompilerError e++ CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)+ CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)+ CompilerError e -> return $ CompilerError e+ {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+ {-# INLINE fail #-}+#endif++instance Fail.MonadFail Compiler where+ fail = compilerThrow . return+ {-# INLINE fail #-}++--------------------------------------------------------------------------------+instance Applicative Compiler where+ pure x = compilerResult $ CompilerDone x mempty+ {-# INLINE pure #-}++ f <*> x = f >>= \f' -> fmap f' x+ {-# INLINE (<*>) #-}+++--------------------------------------------------------------------------------+-- | Access provided metadata from anywhere+instance MonadMetadata Compiler where+ getMetadata = compilerGetMetadata+ getMatches = compilerGetMatches KindContent+ getAllMetadata pattern = do+ matches' <- compilerGetMatches KindMetadata pattern+ forM matches' $ \id' -> do+ metadata <- getMetadata id'+ return (id', metadata)+++--------------------------------------------------------------------------------+-- | Compilation may fail with multiple error messages.+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'+instance MonadError [String] Compiler where+ throwError = compilerThrow+ catchError c = compilerCatch c . (. compilerErrorMessages)+++--------------------------------------------------------------------------------+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's+runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)+runCompiler compiler read' = handle handler $ unCompiler compiler read'+ where+ handler :: SomeException -> IO (CompilerResult a)+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []+++--------------------------------------------------------------------------------+-- | Trying alternative compilers if the first fails, regardless whether through+-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.+-- Aggregates error messages if all fail.+instance Alternative Compiler where+ empty = compilerNoResult []+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->+ case (rx, ry) of+ (CompilationFailure xs, CompilationFailure ys) ->+ compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys+ (CompilationFailure xs, CompilationNoResult ys) ->+ debug ys >> compilerThrow (NonEmpty.toList xs)+ (CompilationNoResult xs, CompilationFailure ys) ->+ debug xs >> compilerThrow (NonEmpty.toList ys)+ (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys+ ))+ where+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"+ {-# INLINE (<|>) #-}+++--------------------------------------------------------------------------------+-- | Put the result back in a compiler+compilerResult :: CompilerResult a -> Compiler a+compilerResult x = Compiler $ \_ -> return x+{-# INLINE compilerResult #-}+++--------------------------------------------------------------------------------+-- | Get the current environment+compilerAsk :: Compiler CompilerRead+compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty+{-# INLINE compilerAsk #-}+++--------------------------------------------------------------------------------+-- | Put a 'CompilerWrite'+compilerTell :: CompilerWrite -> Compiler ()+compilerTell = compilerResult . CompilerDone ()+{-# INLINE compilerTell #-}+++--------------------------------------------------------------------------------+-- | Run an IO computation without dependencies in a Compiler+compilerUnsafeIO :: IO a -> Compiler a+compilerUnsafeIO io = Compiler $ \_ -> do+ x <- io+ return $ CompilerDone x mempty+{-# INLINE compilerUnsafeIO #-}+++--------------------------------------------------------------------------------+-- | Throw errors in the 'Compiler'.+--+-- If no messages are given, this is considered a 'CompilationNoResult' error.+-- Otherwise, it is treated as a proper compilation failure.+compilerThrow :: [String] -> Compiler a+compilerThrow = compilerResult . CompilerError .+ maybe (CompilationNoResult []) CompilationFailure .+ NonEmpty.nonEmpty++-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'+compilerNoResult :: [String] -> Compiler a+compilerNoResult = compilerResult . CompilerError . CompilationNoResult+++--------------------------------------------------------------------------------+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'+--+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)+compilerTry (Compiler x) = Compiler $ \r -> do+ res <- x r+ case res of+ CompilerDone res' w -> return (CompilerDone (Right res') w)+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))+ CompilerRequire i c -> return (CompilerRequire i (compilerTry c))+ CompilerError e -> return (CompilerDone (Left e) mempty)+{-# INLINE compilerTry #-}+++--------------------------------------------------------------------------------+-- | Allows you to recover from 'CompilerError's.+-- Uses the same parameter order as 'catchError' so that it can be used infix.+--+-- prop> c `compilerCatch` f = compilerTry c >>= either f return+compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a+compilerCatch (Compiler x) f = Compiler $ \r -> do+ res <- x r+ case res of+ CompilerDone res' w -> return (CompilerDone res' w)+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))+ CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))+ CompilerError e -> unCompiler (f e) r+{-# INLINE compilerCatch #-}+++--------------------------------------------------------------------------------+compilerDebugLog :: [String] -> Compiler ()+compilerDebugLog ms = do+ logger <- compilerLogger <$> compilerAsk+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger++--------------------------------------------------------------------------------+-- | Pass a list of messages with a heading to the debug logger+compilerDebugEntries :: String -> [String] -> Compiler ()+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent+ where+ indent = unlines . map (" "++) . lines+++--------------------------------------------------------------------------------+compilerTellDependencies :: [Dependency] -> Compiler ()+compilerTellDependencies ds = do+ compilerDebugLog $ map (\d ->+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds+ compilerTell mempty {compilerDependencies = ds}+{-# INLINE compilerTellDependencies #-}+++--------------------------------------------------------------------------------+compilerTellCacheHits :: Int -> Compiler ()+compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}+{-# INLINE compilerTellCacheHits #-}+++--------------------------------------------------------------------------------+compilerGetMetadata :: Identifier -> Compiler Metadata+compilerGetMetadata identifier = do+ provider <- compilerProvider <$> compilerAsk+ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier]+ compilerUnsafeIO $ resourceMetadata provider identifier+++--------------------------------------------------------------------------------+compilerGetMatches :: DependencyKind -> Pattern -> Compiler [Identifier]+compilerGetMatches kind pattern = do+ universe <- compilerUniverse <$> compilerAsk+ let matching = S.filter (matches pattern) universe+ compilerTellDependencies [Dependency kind $ PatternDependency pattern matching]+ pure $ S.toList matching
+ lib/Hakyll/Core/Compiler/Require.hs view
@@ -0,0 +1,137 @@+--------------------------------------------------------------------------------+module Hakyll.Core.Compiler.Require+ ( Snapshot+ , save+ , saveSnapshot+ , load+ , loadSnapshot+ , loadBody+ , loadSnapshotBody+ , loadAll+ , loadAllSnapshots+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (when)+import Data.Binary (Binary)+import Data.Foldable (toList, traverse_)+import Data.Functor.Identity (Identity(Identity, runIdentity))+import qualified Data.Set as S+import Data.Typeable+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Core.Store (Store)+import qualified Hakyll.Core.Store as Store+++--------------------------------------------------------------------------------+save :: (Binary a, Typeable a) => Store -> Item a -> IO ()+save store item = saveSnapshot store final item+++--------------------------------------------------------------------------------+-- | Save a specific snapshot of an item, so you can load it later using+-- 'loadSnapshot'.+saveSnapshot :: (Binary a, Typeable a)+ => Store -> Snapshot -> Item a -> IO ()+saveSnapshot store snapshot item =+ Store.set store (key (itemIdentifier item) snapshot) (itemBody item)+++--------------------------------------------------------------------------------+-- | Load an item compiled elsewhere. If the required item is not yet compiled,+-- the build system will take care of that automatically.+load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)+load id' = loadSnapshot id' final+++--------------------------------------------------------------------------------+-- | Require a specific snapshot of an item.+loadSnapshot :: (Binary a, Typeable a)+ => Identifier -> Snapshot -> Compiler (Item a)+loadSnapshot id' snapshot =+ fmap runIdentity $ loadSnapshotCollection (Identity (id', snapshot))+++--------------------------------------------------------------------------------+-- | A shortcut for only requiring the body of an item.+--+-- > loadBody = fmap itemBody . load+loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a+loadBody id' = loadSnapshotBody id' final+++--------------------------------------------------------------------------------+-- | A shortcut for only requiring the body for a specific snapshot of an item+loadSnapshotBody :: (Binary a, Typeable a)+ => Identifier -> Snapshot -> Compiler a+loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot+++--------------------------------------------------------------------------------+-- | This function allows you to 'load' a dynamic list of items+loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]+loadAll pattern = loadAllSnapshots pattern final+++--------------------------------------------------------------------------------+-- | Load a specific snapshot for each of dynamic list of items+loadAllSnapshots :: (Binary a, Typeable a)+ => Pattern -> Snapshot -> Compiler [Item a]+loadAllSnapshots pattern snapshot = do+ ids <- fmap (\id' -> (id', snapshot)) <$> getMatches pattern+ loadSnapshotCollection ids+++--------------------------------------------------------------------------------+-- | Load a collection of snapshots.+-- Only the first NotFound or WrongType error will be reported.+loadSnapshotCollection :: (Binary a, Typeable a, Traversable t)+ => t (Identifier, Snapshot) -> Compiler (t (Item a))+loadSnapshotCollection ids = do+ store <- compilerStore <$> compilerAsk+ universe <- compilerUniverse <$> compilerAsk++ -- Quick check for better error messages+ let checkMember (id', snap) =+ when (id' `S.notMember` universe) (fail $ notFound id' snap)+ traverse_ checkMember ids++ compilerTellDependencies $ contentDependency . IdentifierDependency . fst <$> toList ids+ let go (id', snap) = do+ result <- compilerUnsafeIO $ Store.get store (key id' snap)+ case result of+ Store.NotFound -> fail $ notFound id' snap+ Store.WrongType e r -> fail $ wrongType id' snap e r+ Store.Found x -> return $ Item id' x+ compilerResult $ CompilerRequire (toList ids) $ traverse go ids+ where+ notFound id' snapshot =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was not found in the cache, " +++ "the cache might be corrupted or " +++ "the item you are referring to might not exist"+ wrongType id' snapshot e r =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was found in the cache, " +++ "but does not have the right type: expected " ++ show e +++ " but got " ++ show r+++--------------------------------------------------------------------------------+key :: Identifier -> String -> [String]+key identifier snapshot =+ ["Hakyll.Core.Compiler.Require", show identifier, snapshot]+++--------------------------------------------------------------------------------+final :: Snapshot+final = "_final"
+ lib/Hakyll/Core/Configuration.hs view
@@ -0,0 +1,165 @@+--------------------------------------------------------------------------------+-- | Exports a datastructure for the top-level hakyll configuration+module Hakyll.Core.Configuration+ ( Configuration (..)+ , shouldIgnoreFile+ , shouldWatchIgnore+ , defaultConfiguration+ ) where+++--------------------------------------------------------------------------------+import Data.Default (Default (..))+import Data.List (isPrefixOf, isSuffixOf)+import qualified Network.Wai.Application.Static as Static+import System.Directory (canonicalizePath)+import System.Exit (ExitCode)+import System.FilePath (isAbsolute, makeRelative, normalise,+ takeExtension, takeFileName)+import System.IO.Error (catchIOError)+import System.Process (system)+++--------------------------------------------------------------------------------+data Configuration = Configuration+ { -- | Directory in which the output written+ destinationDirectory :: FilePath+ , -- | Directory where hakyll's internal store is kept+ storeDirectory :: FilePath+ , -- | Directory in which some temporary files will be kept+ tmpDirectory :: FilePath+ , -- | Directory where hakyll finds the files to compile. This is @.@ by+ -- default.+ providerDirectory :: FilePath+ , -- | Function to determine ignored files+ --+ -- In 'defaultConfiguration', the following files are ignored:+ --+ -- * files starting with a @.@+ --+ -- * files starting with a @#@+ --+ -- * files ending with a @~@+ --+ -- * files ending with @.swp@+ --+ -- Note that the files in 'destinationDirectory' and 'storeDirectory' will+ -- also be ignored. Note that this is the configuration parameter, if you+ -- want to use the test, you should use 'shouldIgnoreFile'.+ --+ ignoreFile :: FilePath -> Bool+ , -- | Function to determine HTML files whose links are to be checked.+ --+ -- In 'defaultConfiguration', files with the @.html@ extension are checked.+ checkHtmlFile :: FilePath -> Bool+ , -- | Function to determine files and directories that should not trigger+ -- a rebuild when touched in watch mode.+ --+ -- Paths are passed in relative to the providerDirectory.+ --+ -- All files that are ignored by 'ignoreFile' are also always ignored by+ -- 'watchIgnore'.+ watchIgnore :: FilePath -> Bool+ , -- | Here, you can plug in a system command to upload/deploy your site.+ --+ -- Example:+ --+ -- > rsync -ave 'ssh -p 2217' _site jaspervdj@jaspervdj.be:hakyll+ --+ -- You can execute this by using+ --+ -- > ./site deploy+ --+ deployCommand :: String+ , -- | Function to deploy the site from Haskell.+ --+ -- By default, this command executes the shell command stored in+ -- 'deployCommand'. If you override it, 'deployCommand' will not+ -- be used implicitely.+ --+ -- The 'Configuration' object is passed as a parameter to this+ -- function.+ --+ deploySite :: Configuration -> IO ExitCode+ , -- | Use an in-memory cache for items. This is faster but uses more+ -- memory.+ inMemoryCache :: Bool+ , -- | Override default host for preview server. Default is "127.0.0.1",+ -- which binds only on the loopback address.+ -- One can also override the host as a command line argument:+ -- ./site preview -h "0.0.0.0"+ previewHost :: String+ , -- | Override default port for preview server. Default is 8000.+ -- One can also override the port as a command line argument:+ -- ./site preview -p 1234+ previewPort :: Int+ , -- | Override other settings used by the preview server. Default is+ -- 'Static.defaultFileServerSettings'.+ previewSettings :: FilePath -> Static.StaticSettings+ }++--------------------------------------------------------------------------------+instance Default Configuration where+ def = defaultConfiguration++--------------------------------------------------------------------------------+-- | Default configuration for a hakyll application+defaultConfiguration :: Configuration+defaultConfiguration = Configuration+ { destinationDirectory = "_site"+ , storeDirectory = "_cache"+ , tmpDirectory = "_cache/tmp"+ , providerDirectory = "."+ , ignoreFile = ignoreFile'+ , checkHtmlFile = flip elem [".html", ".xhtml"] . takeExtension+ , watchIgnore = const False+ , deployCommand = "echo 'No deploy command specified' && exit 1"+ , deploySite = system . deployCommand+ , inMemoryCache = True+ , previewHost = "127.0.0.1"+ , previewPort = 8000+ , previewSettings = Static.defaultFileServerSettings+ }+ where+ ignoreFile' path+ | "." `isPrefixOf` fileName = True+ | "#" `isPrefixOf` fileName = True+ | "~" `isSuffixOf` fileName = True+ | ".swp" `isSuffixOf` fileName = True+ | otherwise = False+ where+ fileName = takeFileName path+++--------------------------------------------------------------------------------+-- | Check if a file should be ignored+shouldIgnoreFile :: Configuration -> FilePath -> IO Bool+shouldIgnoreFile conf path = orM+ [ inDir ("dist-newstyle") -- build directory for cabal-install+ , inDir (".stack-work") -- build directory for stack+ , inDir (destinationDirectory conf)+ , inDir (storeDirectory conf)+ , inDir (tmpDirectory conf)+ , return (ignoreFile conf path')+ ]+ where+ path' = normalise path+ absolute = isAbsolute path++ inDir dir+ | absolute = do+ dir' <- catchIOError (canonicalizePath dir) (const $ return dir)+ return $ dir' `isPrefixOf` path'+ | otherwise = return $ dir `isPrefixOf` path'++ orM :: [IO Bool] -> IO Bool+ orM [] = return False+ orM (x : xs) = x >>= \b -> if b then return True else orM xs++-- | Returns a function to check if a file should be ignored in watch mode+shouldWatchIgnore :: Configuration -> IO (FilePath -> IO Bool)+shouldWatchIgnore conf = do+ fullProviderDir <- canonicalizePath $ providerDirectory conf+ return (\path ->+ let path' = makeRelative fullProviderDir path+ in (|| watchIgnore conf path') <$> shouldIgnoreFile conf path)
+ lib/Hakyll/Core/Dependencies.hs view
@@ -0,0 +1,237 @@+--------------------------------------------------------------------------------+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+module Hakyll.Core.Dependencies+ ( Dependency (..)+ , DependencySelector (..)+ , DependencyKind (..)+ , DependencyFacts+ , outOfDate+ , contentDependency+ , metadataDependency+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (foldM, forM_, unless, when)+import Control.Monad.Reader (ask)+import Control.Monad.RWS (RWS, runRWS)+import qualified Control.Monad.State as State+import Control.Monad.Writer (tell)+import Data.Binary (Binary (..), getWord8,+ putWord8)+import Data.Functor ((<&>))+import Data.List (find)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Typeable (Typeable)+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+++--------------------------------------------------------------------------------+data DependencySelector+ = PatternDependency Pattern (Set Identifier)+ | IdentifierDependency Identifier+ deriving (Show, Typeable)++--------------------------------------------------------------------------------+instance Binary DependencySelector where+ put (PatternDependency p is) = putWord8 0 >> put p >> put is+ put (IdentifierDependency i) = putWord8 1 >> put i+ get = getWord8 >>= \t -> case t of+ 0 -> PatternDependency <$> get <*> get+ 1 -> IdentifierDependency <$> get+ _ -> fail "Data.Binary.get: Invalid DependencySelector"+++--------------------------------------------------------------------------------+-- | A data type representing a dependency on another 'Identifier'. We can+-- depend either on the 'Hakyll.Core.Metadata.Metadata' or the entire content of+-- the underlying file. This is signified by the supplied 'DependencyKind'.+data Dependency+ = Dependency DependencyKind DependencySelector+ | AlwaysOutOfDate+ deriving (Show, Typeable)+++--------------------------------------------------------------------------------+-- | Utility function to create a new content dependency.+contentDependency :: DependencySelector -> Dependency+contentDependency = Dependency KindContent++-- | Utility function to a create a new metadata dependency.+metadataDependency :: DependencySelector -> Dependency+metadataDependency = Dependency KindMetadata+++--------------------------------------------------------------------------------+instance Binary Dependency where+ put AlwaysOutOfDate = putWord8 2+ put (Dependency k s) = putWord8 3 >> put k >> put s++ get = getWord8 >>= \t -> case t of+ -- XXX: Backwards compatability with Hakyll <=4.16.7.1.+ 0 -> (\p i -> contentDependency $ PatternDependency p i) <$> get <*> get+ 1 -> contentDependency . IdentifierDependency <$> get++ 2 -> pure AlwaysOutOfDate+ 3 -> Dependency <$> get <*> get+ _ -> fail "Data.Binary.get: Invalid Dependency"+++--------------------------------------------------------------------------------+type DependencyFacts = Map Identifier [Dependency]+++--------------------------------------------------------------------------------+outOfDate+ :: [Identifier] -- ^ All known identifiers+ -> Set Identifier -- ^ Changed content+ -> Set Identifier -- ^ Changed metadata+ -> DependencyFacts -- ^ Old dependency facts+ -> (Set Identifier, DependencyFacts, [String])+outOfDate universe ood oodMeta oldFacts =+ let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood oodMeta)+ in (dependencyOod state, dependencyFacts state, logs)+ where+ rws = do+ checkNew+ checkChangedPatterns+ bruteForce+++--------------------------------------------------------------------------------+data DependencyState = DependencyState+ { dependencyFacts :: DependencyFacts+ , dependencyOod :: Set Identifier+ , dependencyOodMeta :: Set Identifier+ } deriving (Show)+++--------------------------------------------------------------------------------+type DependencyM a = RWS [Identifier] [String] DependencyState a+++--------------------------------------------------------------------------------+markOod :: Identifier -> DependencyM ()+markOod id' = State.modify $ \s ->+ s {dependencyOod = S.insert id' $ dependencyOod s}+++--------------------------------------------------------------------------------+data DependencyKind = KindContent | KindMetadata+ deriving (Show)++instance Binary DependencyKind where+ put KindContent = putWord8 0+ put KindMetadata = putWord8 1++ get = getWord8 >>= \t -> case t of+ 0 -> pure KindContent+ 1 -> pure KindMetadata+ _ -> fail "Data.Binary.get: Invalid DependencyKind"++--------------------------------------------------------------------------------+-- | Collection of dependencies that should be checked to determine+-- if an identifier needs rebuilding.+data Dependencies+ = DependsOn [(DependencyKind, Identifier)]+ | MustRebuild+ deriving (Show)++instance Semigroup Dependencies where+ DependsOn ids <> DependsOn moreIds = DependsOn (ids <> moreIds)+ MustRebuild <> _ = MustRebuild+ _ <> MustRebuild = MustRebuild++instance Monoid Dependencies where+ mempty = DependsOn []++--------------------------------------------------------------------------------+dependenciesFor :: Identifier -> DependencyM Dependencies+dependenciesFor id' = do+ facts <- dependencyFacts <$> State.get+ return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts+ where+ dependenciesForSelector (IdentifierDependency i) = [i]+ dependenciesForSelector (PatternDependency _ is) = S.toList is++ dependenciesFor' AlwaysOutOfDate = MustRebuild+ dependenciesFor' (Dependency kind selector) = DependsOn $+ map (kind,) $ dependenciesForSelector selector+++--------------------------------------------------------------------------------+checkNew :: DependencyM ()+checkNew = do+ universe <- ask+ facts <- dependencyFacts <$> State.get+ forM_ universe $ \id' -> unless (id' `M.member` facts) $ do+ tell [show id' ++ " is out-of-date because it is new"]+ markOod id'+++--------------------------------------------------------------------------------+checkChangedPatterns :: DependencyM ()+checkChangedPatterns = do+ facts <- M.toList . dependencyFacts <$> State.get+ forM_ facts $ \(id', deps) -> do+ deps' <- foldM (go id') [] deps+ State.modify $ \s -> s+ {dependencyFacts = M.insert id' deps' $ dependencyFacts s}+ where+ go' _ (IdentifierDependency i) = return $ IdentifierDependency i+ go' id' (PatternDependency p ls) = do+ universe <- ask+ let ls' = S.fromList $ filterMatches p universe+ if ls == ls'+ then return $ PatternDependency p ls+ else do+ tell [show id' ++ " is out-of-date because a pattern changed"]+ markOod id'+ return $ PatternDependency p ls'++ go _ ds AlwaysOutOfDate = return $ AlwaysOutOfDate : ds+ go id' ds (Dependency kind select) = (Dependency kind <$> go' id' select) <&> (: ds)+++--------------------------------------------------------------------------------+bruteForce :: DependencyM ()+bruteForce = do+ todo <- ask+ go todo+ where+ go todo = do+ (todo', changed) <- foldM check ([], False) todo+ when changed (go todo')++ findOod oodContent oodMetadata (k, i)+ = S.member i $+ case k of+ KindContent -> oodContent+ KindMetadata -> oodMetadata++ check (todo, changed) id' = do+ deps <- dependenciesFor id'+ case deps of+ DependsOn depList -> do+ ood <- dependencyOod <$> State.get+ oodMeta <- dependencyOodMeta <$> State.get+ case find (findOod ood oodMeta) depList of+ Nothing -> return (id' : todo, changed)+ Just d -> do+ tell [show id' ++ " is out-of-date because " +++ show d ++ " is out-of-date"]+ markOod id'+ return (todo, True)+ MustRebuild -> do+ tell [show id' ++ " will be forcibly rebuilt"]+ markOod id'+ return (todo, True)
+ lib/Hakyll/Core/File.hs view
@@ -0,0 +1,93 @@+--------------------------------------------------------------------------------+-- | Exports simple compilers to just copy files+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hakyll.Core.File+ ( CopyFile (..)+ , copyFileCompiler+ , TmpFile (..)+ , newTmpFile+ ) where+++--------------------------------------------------------------------------------+import Data.Binary (Binary (..))+import Data.Typeable (Typeable)+#if MIN_VERSION_directory(1,2,6)+import System.Directory (copyFileWithMetadata)+#else+import System.Directory (copyFile)+#endif+import System.Directory (doesFileExist,+ renameFile)+import System.FilePath ((</>))+import System.Random (randomIO)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Configuration+import Hakyll.Core.Item+import Hakyll.Core.Provider+import qualified Hakyll.Core.Store as Store+import Hakyll.Core.Util.File+import Hakyll.Core.Writable+++--------------------------------------------------------------------------------+-- | This will copy any file directly by using a system call+newtype CopyFile = CopyFile FilePath+ deriving (Binary, Eq, Ord, Show, Typeable)+++--------------------------------------------------------------------------------+instance Writable CopyFile where+#if MIN_VERSION_directory(1,2,6)+ write dst (Item _ (CopyFile src)) = copyFileWithMetadata src dst+#else+ write dst (Item _ (CopyFile src)) = copyFile src dst+#endif+--------------------------------------------------------------------------------+copyFileCompiler :: Compiler (Item CopyFile)+copyFileCompiler = do+ identifier <- getUnderlying+ provider <- compilerProvider <$> compilerAsk+ makeItem $ CopyFile $ resourceFilePath provider identifier+++--------------------------------------------------------------------------------+newtype TmpFile = TmpFile FilePath+ deriving (Typeable)+++--------------------------------------------------------------------------------+instance Binary TmpFile where+ put _ = return ()+ get = error $+ "Hakyll.Core.File.TmpFile: You tried to load a TmpFile, however, " +++ "this is not possible since these are deleted as soon as possible."+++--------------------------------------------------------------------------------+instance Writable TmpFile where+ write dst (Item _ (TmpFile fp)) = renameFile fp dst+++--------------------------------------------------------------------------------+-- | Create a tmp file+newTmpFile :: String -- ^ Suffix and extension+ -> Compiler TmpFile -- ^ Resulting tmp path+newTmpFile suffix = do+ path <- mkPath+ compilerUnsafeIO $ makeDirectories path+ debugCompiler $ "newTmpFile " ++ path+ return $ TmpFile path+ where+ mkPath = do+ rand <- compilerUnsafeIO $ randomIO :: Compiler Int+ tmp <- tmpDirectory . compilerConfig <$> compilerAsk+ let path = tmp </> Store.hash [show rand] ++ "-" ++ suffix+ exists <- compilerUnsafeIO $ doesFileExist path+ if exists then mkPath else return path
+ lib/Hakyll/Core/Identifier.hs view
@@ -0,0 +1,169 @@+--------------------------------------------------------------------------------+-- | An identifier is a type used to uniquely name an item. An identifier+-- is similar to a file path, but can contain additional details (e.g.+-- item's version). Examples of identifiers are:+--+-- * @posts/foo.markdown@+--+-- * @index@+--+-- * @error/404@+--+-- See 'Identifier' for details.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hakyll.Core.Identifier+ ( Identifier+ , fromFilePath+ , toFilePath+ , identifierVersion+ , setVersion+ ) where+++--------------------------------------------------------------------------------+import Control.DeepSeq (NFData (..))+import System.FilePath (normalise)+++--------------------------------------------------------------------------------+import Data.Binary (Binary (..))+import Data.Typeable (Typeable)+import GHC.Exts (IsString, fromString)+++--------------------------------------------------------------------------------+{- | A key data type to identify a compiled 'Hakyll.Core.Item.Item' in the 'Hakyll.Core.Store.Store'.+Conceptually, it's a combination of a file path and a version name.+The version is used only when a file is+compiled within a rule using the 'version' wrapper function+(the same source file+can be compiled into several items in the store, so the version exists to distinguish+them).+Use functions like 'fromFilePath', 'setVersion', 'Hakyll.Core.Metadata.getMatches' to build an 'Identifier'.++=== __Usage Examples__+Normally, compiled items are saved to the store by 'Hakyll.Core.Rules.Rules' with an automatic, implicit identifier+and loaded from the store by the user in another rule with a manual, explicit identifier.++__Identifiers when using match__.+Using 'Hakyll.Core.Rules.match' builds an implicit identifier that corresponds to the expanded, relative path+of the source file on disk (relative to the project directory configured+with 'Hakyll.Core.Configuration.providerDirectory'):++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+Normally, the identifier is only explicitly created to pass to one of the 'Hakyll.Core.Compiler.load' functions.++__Identifiers when using create__.+Using 'Hakyll.Core.Rules.create' (thereby inventing a file path with no underlying file on disk)+builds an implicit identifier that corresponds to the invented file path:++@+create ["index.html"] $ do -- saved with implicit identifier 'index.html'+ compile $ makeItem ("Hello world" :: String)++match "about/*" $ do+ compile $ do+ compiledIndex <- load (fromFilePath "index.html") -- load with an explicit identifier+ ...+@++__Identifiers when using versions__.+With 'Hakyll.Core.Rules.version' the same file can be compiled into several items in the store.+A version name is needed to distinguish them:++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier ('posts\/hakyll.md', no-version)+ compile pandocCompiler++match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load no-version version+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+Use 'setVersion' to set (or replace) the version of an identifier like @fromFilePath "posts/hakyll.md"@.+-}+data Identifier = Identifier+ { identifierVersion :: Maybe String+ , identifierPath :: String+ } deriving (Eq, Ord, Typeable)+++--------------------------------------------------------------------------------+instance Binary Identifier where+ put (Identifier v p) = put v >> put p+ get = Identifier <$> get <*> get+++--------------------------------------------------------------------------------+instance IsString Identifier where+ fromString = fromFilePath+++--------------------------------------------------------------------------------+instance NFData Identifier where+ rnf (Identifier v p) = rnf v `seq` rnf p `seq` ()+++--------------------------------------------------------------------------------+instance Show Identifier where+ show i = case identifierVersion i of+ Nothing -> toFilePath i+ Just v -> toFilePath i ++ " (" ++ v ++ ")"+++--------------------------------------------------------------------------------+{- | Parse an identifier from a file path string. For example,++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+-}+fromFilePath :: FilePath -> Identifier+fromFilePath = Identifier Nothing . normalise+++--------------------------------------------------------------------------------+-- | Convert an identifier back to a relative 'FilePath'.+toFilePath :: Identifier -> FilePath+toFilePath = normalise . identifierPath+++--------------------------------------------------------------------------------+{- | Set or override the version of an identifier in order to specify which version of an 'Hakyll.Core.Item.Item'+to 'Hakyll.Core.Compiler.load' from the 'Hakyll.Core.Store.Store'. For example,++@+match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+-}+setVersion :: Maybe String -> Identifier -> Identifier+setVersion v i = i {identifierVersion = v}
+ lib/Hakyll/Core/Identifier/Pattern.hs view
@@ -0,0 +1,266 @@+--------------------------------------------------------------------------------+-- | As 'Identifier' is used to specify a single item, a 'Pattern' is used to+-- specify a list of items.+--+-- In most cases, globs are used for patterns.+--+-- A very simple pattern of such a pattern is @\"foo\/bar\"@. This pattern will+-- only match the exact @foo\/bar@ identifier.+--+-- To match more than one identifier, there are different captures that one can+-- use:+--+-- * @\"*\"@: matches at most one element of an identifier;+--+-- * @\"**\"@: matches one or more elements of an identifier.+--+-- Some examples:+--+-- * @\"foo\/*\"@ will match @\"foo\/bar\"@ and @\"foo\/foo\"@, but not+-- @\"foo\/bar\/qux\"@;+--+-- * @\"**\"@ will match any identifier;+--+-- * @\"foo\/**\"@ will match @\"foo\/bar\"@ and @\"foo\/bar\/qux\"@, but not+-- @\"bar\/foo\"@;+--+-- * @\"foo\/*.html\"@ will match all HTML files in the @\"foo\/\"@ directory.+--+-- The 'capture' function allows the user to get access to the elements captured+-- by the capture elements in a glob or regex pattern.+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Hakyll.Core.Identifier.Pattern+ ( -- * The pattern type+ Pattern++ -- * Creating patterns+ , fromGlob+ , fromList+ , fromRegex+ , fromVersion+ , hasVersion+ , hasNoVersion++ -- * Composing patterns+ , (.&&.)+ , (.||.)+ , complement++ -- * Applying patterns+ , matches+ , filterMatches++ -- * Capturing strings+ , capture+ , fromCapture+ , fromCaptures+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow ((&&&), (>>>))+import Control.Monad (msum)+import Data.List (inits, isPrefixOf,+ tails)+import Data.Maybe (isJust)+import qualified Data.Set as S+import System.FilePath (normalise, pathSeparator)+++--------------------------------------------------------------------------------+import GHC.Exts (IsString, fromString)+import Text.Regex.TDFA ((=~))+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern.Internal+import Hakyll.Core.Util.String (removeWinPathSeparator)+++--------------------------------------------------------------------------------+instance IsString Pattern where+ fromString = fromGlob+++--------------------------------------------------------------------------------+-- | Parse a pattern from a string+fromGlob :: String -> Pattern+fromGlob = Glob . parse' . normalise+ where+ parse' str = + let (chunk, rest) = break (== '*') str+ in case rest of+ ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs+ ('*' : xs) -> Literal chunk : Capture : parse' xs+ "" -> Literal chunk : []+ xs -> Literal chunk : Literal xs : []+++--------------------------------------------------------------------------------+-- | Create a 'Pattern' from a list of 'Identifier's it should match.+--+-- /Warning/: use this carefully with 'hasNoVersion' and 'hasVersion'. The+-- 'Identifier's in the list /already/ have versions assigned, and the pattern+-- will then only match the intersection of both versions.+--+-- A more concrete example,+--+-- > fromList ["foo.markdown"] .&&. hasVersion "pdf"+--+-- will not match anything! The @"foo.markdown"@ 'Identifier' has no version+-- assigned, so the LHS of '.&&.' will only match this 'Identifier' with no+-- version. The RHS only matches 'Identifier's with version set to @"pdf"@ --+-- hence, this pattern matches nothing.+--+-- The correct way to use this is:+--+-- > fromList $ map (setVersion $ Just "pdf") ["foo.markdown"]+fromList :: [Identifier] -> Pattern+fromList = List . S.fromList+++--------------------------------------------------------------------------------+-- | Create a 'Pattern' from a regex+--+-- Example:+--+-- > regex "^foo/[^x]*$+fromRegex :: String -> Pattern+fromRegex = Regex+++--------------------------------------------------------------------------------+-- | Create a pattern which matches all items with the given version.+fromVersion :: Maybe String -> Pattern+fromVersion = Version+++--------------------------------------------------------------------------------+-- | Specify a version, e.g.+--+-- > "foo/*.markdown" .&&. hasVersion "pdf"+hasVersion :: String -> Pattern+hasVersion = fromVersion . Just+++--------------------------------------------------------------------------------+-- | Match only if the identifier has no version set, e.g.+--+-- > "foo/*.markdown" .&&. hasNoVersion+hasNoVersion :: Pattern+hasNoVersion = fromVersion Nothing+++--------------------------------------------------------------------------------+-- | '&&' for patterns: the given identifier must match both subterms+(.&&.) :: Pattern -> Pattern -> Pattern+x .&&. y = And x y+infixr 3 .&&.+++--------------------------------------------------------------------------------+-- | '||' for patterns: the given identifier must match any subterm+(.||.) :: Pattern -> Pattern -> Pattern+x .||. y = complement (complement x `And` complement y) -- De Morgan's law+infixr 2 .||.+++--------------------------------------------------------------------------------+-- | Inverts a pattern, e.g.+--+-- > complement "foo/bar.html"+--+-- will match /anything/ except @\"foo\/bar.html\"@+complement :: Pattern -> Pattern+complement = Complement+++--------------------------------------------------------------------------------+-- | Check if an identifier matches a pattern+matches :: Pattern -> Identifier -> Bool+matches Everything _ = True+matches (Complement p) i = not $ matches p i+matches (And x y) i = matches x i && matches y i+matches (Glob p) i = isJust $ capture (Glob p) i+matches (List l) i = i `S.member` l+matches (Regex r) i = (removeWinPathSeparator $ toFilePath i) =~ r+matches (Version v) i = identifierVersion i == v+++--------------------------------------------------------------------------------+-- | Given a list of identifiers, retain only those who match the given pattern+filterMatches :: Pattern -> [Identifier] -> [Identifier]+filterMatches = filter . matches+++--------------------------------------------------------------------------------+-- | Split a list at every possible point, generate a list of (init, tail)+-- cases. The result is sorted with inits decreasing in length.+splits :: [a] -> [([a], [a])]+splits = inits &&& tails >>> uncurry zip >>> reverse+++--------------------------------------------------------------------------------+-- | Match a glob or regex pattern against an identifier, generating a list of captures+capture :: Pattern -> Identifier -> Maybe [String]+capture (Glob p) i = capture' p (toFilePath i)+capture (Regex pat) i = Just groups+ where (_, _, _, groups) = ((removeWinPathSeparator $ toFilePath i) =~ pat) :: (String, String, String, [String])+capture _ _ = Nothing+++--------------------------------------------------------------------------------+-- | Internal verion of 'capture'+capture' :: [GlobComponent] -> String -> Maybe [String]+capture' [] [] = Just [] -- An empty match+capture' [] _ = Nothing -- No match+capture' (Literal l : ms) str+ -- Match the literal against the string+ | l `isPrefixOf` str = capture' ms $ drop (length l) str+ | otherwise = Nothing+capture' (Capture : ms) str =+ -- Match until the next path separator+ let (chunk, rest) = break (== pathSeparator) str+ in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]+capture' (CaptureMany : ms) str =+ -- Match everything+ msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]+++--------------------------------------------------------------------------------+-- | Create an identifier from a pattern by filling in the captures with a given+-- string+--+-- Example:+--+-- > fromCapture (fromGlob "tags/*") "foo"+--+-- Result:+--+-- > "tags/foo"+fromCapture :: Pattern -> String -> Identifier+fromCapture pattern = fromCaptures pattern . repeat+++--------------------------------------------------------------------------------+-- | Create an identifier from a pattern by filling in the captures with the+-- given list of strings+fromCaptures :: Pattern -> [String] -> Identifier+fromCaptures (Glob p) = fromFilePath . fromCaptures' p+fromCaptures _ = error $+ "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " +++ "on simple globs!"+++--------------------------------------------------------------------------------+-- | Internally used version of 'fromCaptures'+fromCaptures' :: [GlobComponent] -> [String] -> String+fromCaptures' [] _ = mempty+fromCaptures' (m : ms) [] = case m of+ Literal l -> l `mappend` fromCaptures' ms []+ _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "+ ++ "identifier list exhausted"+fromCaptures' (m : ms) ids@(i : is) = case m of+ Literal l -> l `mappend` fromCaptures' ms ids+ _ -> i `mappend` fromCaptures' ms is
+ lib/Hakyll/Core/Identifier/Pattern/Internal.hs view
@@ -0,0 +1,79 @@+-- | This internal module is mostly here to prevent CPP conflicting with Haskell+-- comments.+module Hakyll.Core.Identifier.Pattern.Internal+ ( GlobComponent (..)+ , Pattern (..)+ ) where+++--------------------------------------------------------------------------------+import Data.Binary (Binary (..), getWord8, putWord8)+import Data.Set (Set)+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+++--------------------------------------------------------------------------------+-- | Elements of a glob pattern+data GlobComponent+ = Capture+ | CaptureMany+ | Literal String+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+instance Binary GlobComponent where+ put Capture = putWord8 0+ put CaptureMany = putWord8 1+ put (Literal s) = putWord8 2 >> put s++ get = getWord8 >>= \t -> case t of+ 0 -> pure Capture+ 1 -> pure CaptureMany+ 2 -> Literal <$> get+ _ -> error "Data.Binary.get: Invalid GlobComponent"+++--------------------------------------------------------------------------------+-- | Type that allows matching on identifiers+data Pattern+ = Everything+ | Complement Pattern+ | And Pattern Pattern+ | Glob [GlobComponent]+ | List (Set Identifier)+ | Regex String+ | Version (Maybe String)+ deriving (Show)+++--------------------------------------------------------------------------------+instance Binary Pattern where+ put Everything = putWord8 0+ put (Complement p) = putWord8 1 >> put p+ put (And x y) = putWord8 2 >> put x >> put y+ put (Glob g) = putWord8 3 >> put g+ put (List is) = putWord8 4 >> put is+ put (Regex r) = putWord8 5 >> put r+ put (Version v) = putWord8 6 >> put v++ get = getWord8 >>= \t -> case t of+ 0 -> pure Everything+ 1 -> Complement <$> get+ 2 -> And <$> get <*> get+ 3 -> Glob <$> get+ 4 -> List <$> get+ 5 -> Regex <$> get+ _ -> Version <$> get+++--------------------------------------------------------------------------------+instance Semigroup Pattern where+ (<>) = And++instance Monoid Pattern where+ mempty = Everything+ mappend = (<>)
+ lib/Hakyll/Core/Item.hs view
@@ -0,0 +1,47 @@+--------------------------------------------------------------------------------+-- | An item is a combination of some content and its 'Identifier'. This way, we+-- can still use the 'Identifier' to access metadata.+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+module Hakyll.Core.Item+ ( Item (..)+ , itemSetBody+ , withItemBody+ ) where+++--------------------------------------------------------------------------------+import Data.Binary (Binary (..))+import Data.Typeable (Typeable)+import Prelude hiding (foldr)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier+++--------------------------------------------------------------------------------+data Item a = Item+ { itemIdentifier :: Identifier+ , itemBody :: a+ } deriving (Show, Typeable, Functor, Foldable, Traversable)++--------------------------------------------------------------------------------+instance Binary a => Binary (Item a) where+ put (Item i x) = put i >> put x+ get = Item <$> get <*> get+++--------------------------------------------------------------------------------+itemSetBody :: a -> Item b -> Item a+itemSetBody x (Item i _) = Item i x+++--------------------------------------------------------------------------------+-- | Perform a compiler action on the item body. This is the same as 'traverse',+-- but looks less intimidating.+--+-- > withItemBody = traverse+withItemBody :: (a -> Compiler b) -> Item a -> Compiler (Item b)+withItemBody = traverse
+ lib/Hakyll/Core/Item/SomeItem.hs view
@@ -0,0 +1,23 @@+--------------------------------------------------------------------------------+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+module Hakyll.Core.Item.SomeItem+ ( SomeItem (..)+ ) where+++--------------------------------------------------------------------------------+import Data.Binary (Binary)+import Data.Typeable (Typeable)+++--------------------------------------------------------------------------------+import Hakyll.Core.Item+import Hakyll.Core.Writable+++--------------------------------------------------------------------------------+-- | An existential type, mostly for internal usage.+data SomeItem = forall a.+ (Binary a, Typeable a, Writable a) => SomeItem (Item a)+ deriving (Typeable)
+ lib/Hakyll/Core/Logger.hs view
@@ -0,0 +1,107 @@+--------------------------------------------------------------------------------+-- | Produce pretty, thread-safe logs+{-# LANGUAGE Rank2Types #-}+module Hakyll.Core.Logger+ ( Verbosity (..)+ , Logger+ , new+ , flush+ , error+ , header+ , message+ , debug++ -- * Testing utilities+ , newInMem+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Concurrent.Chan (newChan, readChan, writeChan)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad (forever, when)+import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.IORef as IORef+import Data.List (intercalate)+import Prelude hiding (error)+++--------------------------------------------------------------------------------+data Verbosity+ = Error+ | Message+ | Debug+ deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+data Logger = Logger+ { -- | Flush the logger (blocks until flushed)+ flush :: forall m. MonadIO m => m ()+ , string :: forall m. MonadIO m => Verbosity -> String -> m ()+ }+++--------------------------------------------------------------------------------+-- | Create a new logger+new :: Verbosity -> IO Logger+new vbty = do+ chan <- newChan+ sync <- newEmptyMVar+ _ <- forkIO $ forever $ do+ msg <- readChan chan+ case msg of+ -- Stop: sync+ Nothing -> putMVar sync ()+ -- Print and continue+ Just m -> putStrLn m+ return $ Logger+ { flush = liftIO $ do+ writeChan chan Nothing+ () <- takeMVar sync+ return ()+ , string = \v m -> when (vbty >= v) $+ liftIO $ writeChan chan (Just m)+ }+++--------------------------------------------------------------------------------+error :: MonadIO m => Logger -> String -> m ()+error l m = string l Error $ " [ERROR] " ++ indent m+++--------------------------------------------------------------------------------+header :: MonadIO m => Logger -> String -> m ()+header l = string l Message+++--------------------------------------------------------------------------------+message :: MonadIO m => Logger -> String -> m ()+message l m = string l Message $ " " ++ indent m+++--------------------------------------------------------------------------------+debug :: MonadIO m => Logger -> String -> m ()+debug l m = string l Debug $ " [DEBUG] " ++ indent m+++--------------------------------------------------------------------------------+indent :: String -> String+indent = intercalate "\n " . lines+++--------------------------------------------------------------------------------+-- | Create a new logger that just stores all the messages, useful for writing+-- tests.+newInMem :: IO (Logger, IO [(Verbosity, String)])+newInMem = do+ ref <- IORef.newIORef []+ pure+ ( Logger+ { string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $+ \msgs -> ((vbty, msg) : msgs, ())+ , flush = pure ()+ }+ , reverse <$> IORef.readIORef ref+ )
+ lib/Hakyll/Core/Metadata.hs view
@@ -0,0 +1,168 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module Hakyll.Core.Metadata+ ( Metadata+ , lookupString+ , lookupStringList++ , MonadMetadata (..)+ , getMetadataField+ , getMetadataField'+ , makePatternDependency++ , BinaryMetadata (..)+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (forM)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.Binary (Binary (..), getWord8,+ putWord8, Get)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap+#endif+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Yaml.Extended as Yaml+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+++--------------------------------------------------------------------------------+type Metadata = Yaml.Object+++--------------------------------------------------------------------------------+lookupString :: String -> Metadata -> Maybe String+lookupString key meta = KeyMap.lookup (keyFromString key) meta >>= Yaml.toString+++--------------------------------------------------------------------------------+lookupStringList :: String -> Metadata -> Maybe [String]+lookupStringList key meta =+ KeyMap.lookup (keyFromString key) meta >>= Yaml.toList >>= mapM Yaml.toString+++--------------------------------------------------------------------------------+class Monad m => MonadMetadata m where+ getMetadata :: Identifier -> m Metadata+ getMatches :: Pattern -> m [Identifier]++ getAllMetadata :: Pattern -> m [(Identifier, Metadata)]+ getAllMetadata pattern = do+ matches' <- getMatches pattern+ forM matches' $ \id' -> do+ metadata <- getMetadata id'+ return (id', metadata)+++--------------------------------------------------------------------------------+getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)+getMetadataField identifier key = do+ metadata <- getMetadata identifier+ return $ lookupString key metadata+++--------------------------------------------------------------------------------+-- | Version of 'getMetadataField' which throws an error if the field does not+-- exist.+getMetadataField' :: (MonadFail m, MonadMetadata m) => Identifier -> String -> m String+getMetadataField' identifier key = do+ field <- getMetadataField identifier key+ case field of+ Just v -> return v+ Nothing -> fail $ "Hakyll.Core.Metadata.getMetadataField': " +++ "Item " ++ show identifier ++ " has no metadata field " ++ show key+++--------------------------------------------------------------------------------+makePatternDependency :: MonadMetadata m => DependencyKind -> Pattern -> m Dependency+makePatternDependency kind pattern = do+ matches' <- getMatches pattern+ return $ Dependency kind (PatternDependency pattern (S.fromList matches'))+++--------------------------------------------------------------------------------+-- | Newtype wrapper for serialization.+newtype BinaryMetadata = BinaryMetadata+ {unBinaryMetadata :: Metadata}+++instance Binary BinaryMetadata where+ put (BinaryMetadata obj) = put (BinaryYaml $ Yaml.Object obj)+ get = do+ BinaryYaml (Yaml.Object obj) <- get+ return $ BinaryMetadata obj+++--------------------------------------------------------------------------------+newtype BinaryYaml = BinaryYaml {unBinaryYaml :: Yaml.Value}+++--------------------------------------------------------------------------------+instance Binary BinaryYaml where+ put (BinaryYaml yaml) = case yaml of+ Yaml.Object obj -> do+ putWord8 0+ let list :: [(T.Text, BinaryYaml)]+ list = map (\(k, v) -> (keyToText k, BinaryYaml v)) $ KeyMap.toList obj+ put list++ Yaml.Array arr -> do+ putWord8 1+ let list = map BinaryYaml (V.toList arr) :: [BinaryYaml]+ put list++ Yaml.String s -> putWord8 2 >> put s+ Yaml.Number n -> putWord8 3 >> put n+ Yaml.Bool b -> putWord8 4 >> put b+ Yaml.Null -> putWord8 5++ get = do+ tag <- getWord8+ case tag of+ 0 -> do+ list <- get :: Get [(T.Text, BinaryYaml)]+ return $ BinaryYaml $ Yaml.Object $+ KeyMap.fromList $ map (\(k, v) -> (keyFromText k, unBinaryYaml v)) list++ 1 -> do+ list <- get :: Get [BinaryYaml]+ return $ BinaryYaml $+ Yaml.Array $ V.fromList $ map unBinaryYaml list++ 2 -> BinaryYaml . Yaml.String <$> get+ 3 -> BinaryYaml . Yaml.Number <$> get+ 4 -> BinaryYaml . Yaml.Bool <$> get+ 5 -> return $ BinaryYaml Yaml.Null+ _ -> fail "Data.Binary.get: Invalid Binary Metadata"+++--------------------------------------------------------------------------------+#if MIN_VERSION_aeson(2,0,0)+keyFromString :: String -> AK.Key+keyFromString = AK.fromString++keyToText :: AK.Key -> T.Text+keyToText = AK.toText++keyFromText :: T.Text -> AK.Key+keyFromText = AK.fromText+#else+keyFromString :: String -> T.Text+keyFromString = T.pack++keyToText :: T.Text -> T.Text+keyToText = id++keyFromText :: T.Text -> T.Text+keyFromText = id+#endif
+ lib/Hakyll/Core/Provider.hs view
@@ -0,0 +1,59 @@+--------------------------------------------------------------------------------+-- | This module provides an wrapper API around the file system which does some+-- caching.+module Hakyll.Core.Provider+ ( -- * Constructing resource providers+ Internal.Provider+ , newProvider++ -- * Querying resource properties+ , Internal.resourceList+ , Internal.resourceExists+ , Internal.resourceFilePath+ , Internal.resourceModified+ , Internal.resourceModificationTime++ -- * Access to raw resource content+ , Internal.resourceString+ , Internal.resourceLBS++ -- * Access to metadata and body content+ , Internal.resourceMetadata+ , Internal.resourceBody+ ) where++--------------------------------------------------------------------------------+import Control.Monad (forM)+import qualified Hakyll.Core.Provider.Internal as Internal+import qualified Hakyll.Core.Provider.MetadataCache as Internal+import Hakyll.Core.Store (Store)+import Hakyll.Core.Identifier (Identifier)+++--------------------------------------------------------------------------------+-- | Create a resource provider+newProvider :: Store -- ^ Store to use+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?+ -> FilePath -- ^ Search directory+ -> IO (Internal.Provider, [Identifier]) -- ^ Resulting provider and modified metadata+newProvider store ignore directory = do+ p <- Internal.newProvider store ignore directory++ let modified =+ filter+ (Internal.resourceModified p)+ (Internal.resourceList p)++ -- Delete metadata cache where necessary and extract identifiers for which the+ -- metadata was actually modified. That is, exclude identifiers where the body+ -- was modified but the metadata wasn't.+ modifiedMetadata <- fmap concat $ forM modified $ \identifier -> do+ mbCachedMetadata <- Internal.resourceLookupMetadataCache p identifier+ case mbCachedMetadata of+ Nothing -> pure []+ Just oldMeta -> do+ Internal.resourceInvalidateMetadataCache p identifier+ newMeta <- Internal.resourceMetadata p identifier+ pure $ if oldMeta == newMeta then [] else [identifier]++ return (p, modifiedMetadata)
+ lib/Hakyll/Core/Provider/Internal.hs view
@@ -0,0 +1,202 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hakyll.Core.Provider.Internal+ ( ResourceInfo (..)+ , Provider (..)+ , newProvider++ , resourceList+ , resourceExists++ , resourceFilePath+ , resourceString+ , resourceLBS++ , resourceModified+ , resourceModificationTime+ ) where+++--------------------------------------------------------------------------------+import Control.DeepSeq (NFData (..), deepseq)+import Control.Monad (forM)+import Data.Binary (Binary (..))+import qualified Data.ByteString.Lazy as BL+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Time (Day (..), UTCTime (..))+import Data.Typeable (Typeable)+import System.Directory (getModificationTime)+import System.FilePath (addExtension, (</>))+++--------------------------------------------------------------------------------+#if !MIN_VERSION_directory(1,2,0)+import Data.Time (readTime)+import System.Locale (defaultTimeLocale)+import System.Time (formatCalendarTime, toCalendarTime)+#endif+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Store (Store)+import qualified Hakyll.Core.Store as Store+import Hakyll.Core.Util.File+++--------------------------------------------------------------------------------+-- | Because UTCTime doesn't have a Binary instance...+newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}+ deriving (Eq, NFData, Ord, Show, Typeable)+++--------------------------------------------------------------------------------+instance Binary BinaryTime where+ put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =+ put d >> put (toRational dt)++ get = fmap BinaryTime $ UTCTime+ <$> (ModifiedJulianDay <$> get)+ <*> (fromRational <$> get)+++--------------------------------------------------------------------------------+data ResourceInfo = ResourceInfo+ { resourceInfoModified :: BinaryTime+ , resourceInfoMetadata :: Maybe Identifier+ } deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Binary ResourceInfo where+ put (ResourceInfo mtime meta) = put mtime >> put meta+ get = ResourceInfo <$> get <*> get+++--------------------------------------------------------------------------------+instance NFData ResourceInfo where+ rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()+++--------------------------------------------------------------------------------+-- | Responsible for retrieving and listing resources+data Provider = Provider+ { -- Top of the provided directory+ providerDirectory :: FilePath+ , -- | A list of all files found+ providerFiles :: Map Identifier ResourceInfo+ , -- | A list of the files from the previous run+ providerOldFiles :: Map Identifier ResourceInfo+ , -- | Underlying persistent store for caching+ providerStore :: Store+ } deriving (Show)+++--------------------------------------------------------------------------------+-- | Create a resource provider+newProvider :: Store -- ^ Store to use+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?+ -> FilePath -- ^ Search directory+ -> IO Provider -- ^ Resulting provider+newProvider store ignore directory = do+ list <- map fromFilePath <$> getRecursiveContents ignore directory+ let universe = S.fromList list+ files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do+ rInfo <- getResourceInfo directory universe identifier+ return (identifier, rInfo)++ -- Get the old files from the store, and then immediately replace them by+ -- the new files.+ oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey+ oldFiles `deepseq` Store.set store oldKey files++ return $ Provider directory files oldFiles store+ where+ oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]++ -- Update modified if metadata is modified+ maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->+ let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files+ in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}+++--------------------------------------------------------------------------------+getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo+getResourceInfo directory universe identifier = do+ mtime <- fileModificationTime $ directory </> toFilePath identifier+ return $ ResourceInfo (BinaryTime mtime) $+ if mdRsc `S.member` universe then Just mdRsc else Nothing+ where+ mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier+++--------------------------------------------------------------------------------+resourceList :: Provider -> [Identifier]+resourceList = M.keys . providerFiles+++--------------------------------------------------------------------------------+-- | Check if a given resource exists+resourceExists :: Provider -> Identifier -> Bool+resourceExists provider =+ (`M.member` providerFiles provider) . setVersion Nothing+++--------------------------------------------------------------------------------+resourceFilePath :: Provider -> Identifier -> FilePath+resourceFilePath p i = providerDirectory p </> toFilePath i+++--------------------------------------------------------------------------------+-- | Get the raw body of a resource as string+resourceString :: Provider -> Identifier -> IO String+resourceString p i = readFile $ resourceFilePath p i+++--------------------------------------------------------------------------------+-- | Get the raw body of a resource of a lazy bytestring+resourceLBS :: Provider -> Identifier -> IO BL.ByteString+resourceLBS p i = BL.readFile $ resourceFilePath p i+++--------------------------------------------------------------------------------+-- | A resource is modified if it or its metadata has changed+resourceModified :: Provider -> Identifier -> Bool+resourceModified p r = case (ri, oldRi) of+ (Nothing, _) -> False+ (Just _, Nothing) -> True+ (Just n, Just o) ->+ resourceInfoModified n > resourceInfoModified o ||+ resourceInfoMetadata n /= resourceInfoMetadata o+ where+ normal = setVersion Nothing r+ ri = M.lookup normal (providerFiles p)+ oldRi = M.lookup normal (providerOldFiles p)+++--------------------------------------------------------------------------------+resourceModificationTime :: Provider -> Identifier -> UTCTime+resourceModificationTime p i =+ case M.lookup (setVersion Nothing i) (providerFiles p) of+ Just ri -> unBinaryTime $ resourceInfoModified ri+ Nothing -> error $+ "Hakyll.Core.Provider.Internal.resourceModificationTime: " +++ "resource " ++ show i ++ " does not exist"+++--------------------------------------------------------------------------------+fileModificationTime :: FilePath -> IO UTCTime+fileModificationTime fp = do+#if MIN_VERSION_directory(1,2,0)+ getModificationTime fp+#else+ ct <- toCalendarTime =<< getModificationTime fp+ let str = formatCalendarTime defaultTimeLocale "%s" ct+ return $ readTime defaultTimeLocale "%s" str+#endif
+ lib/Hakyll/Core/Provider/Metadata.hs view
@@ -0,0 +1,151 @@+--------------------------------------------------------------------------------+-- | Internal module to parse metadata+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+module Hakyll.Core.Provider.Metadata+ ( loadMetadata+ , parsePage++ , MetadataException (..)+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow (second)+import Control.Exception (Exception, throwIO)+import Control.Monad (guard)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.List.Extended (breakWhen)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Yaml as Yaml+import Hakyll.Core.Identifier+import Hakyll.Core.Metadata+import Hakyll.Core.Provider.Internal+import System.IO as IO+import System.IO.Error (modifyIOError, ioeSetLocation)+++--------------------------------------------------------------------------------+loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)+loadMetadata p identifier = do+ hasHeader <- probablyHasMetadataHeader fp+ (md, body) <- if hasHeader+ then second Just <$> loadMetadataHeader fp+ else return (mempty, Nothing)++ emd <- case mi of+ Nothing -> return mempty+ Just mi' -> loadMetadataFile $ resourceFilePath p mi'++ return (md <> emd, body)+ where+ normal = setVersion Nothing identifier+ fp = resourceFilePath p identifier+ mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata+++--------------------------------------------------------------------------------+loadMetadataHeader :: FilePath -> IO (Metadata, String)+loadMetadataHeader fp = do+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp+ case parsePage fileContent of+ Right x -> return x+ Left err -> throwIO $ MetadataException fp err+++--------------------------------------------------------------------------------+loadMetadataFile :: FilePath -> IO Metadata+loadMetadataFile fp = do+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp+ let errOrMeta = Yaml.decodeEither' fileContent+ either (fail . show) return errOrMeta+++--------------------------------------------------------------------------------+-- | Check if a file "probably" has a metadata header. The main goal of this is+-- to exclude binary files (which are unlikely to start with "---").+probablyHasMetadataHeader :: FilePath -> IO Bool+probablyHasMetadataHeader fp = do+ handle <- IO.openFile fp IO.ReadMode+ bs <- BC.hGet handle 1024+ IO.hClose handle+ return $ isMetadataHeader bs+ where+ isMetadataHeader bs =+ let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs+ in BC.length pre >= 3 && BC.all (== '-') pre+++--------------------------------------------------------------------------------+-- | Parse the page metadata and body.+splitMetadata :: String -> (Maybe String, String)+splitMetadata str0 = fromMaybe (Nothing, str0) $ do+ guard $ leading >= 3+ let !str1 = drop leading str0+ guard $ all isNewline (take 1 str1)+ let !(!meta, !content0) = breakWhen isTrailing str1+ guard $ not $ null content0+ let !content1 = drop (leading + 1) content0+ !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1+ -- Adding this newline fixes the line numbers reported by the YAML parser.+ -- It's a bit ugly but it works.+ return (Just ('\n' : meta), content2)+ where+ -- Parse the leading "---"+ !leading = length $ takeWhile (== '-') str0++ -- Predicate to recognize the trailing "---" or "..."+ isTrailing [] = False+ isTrailing (x : xs) =+ isNewline x && length (takeWhile isDash xs) == leading++ -- Characters+ isNewline c = c == '\n' || c == '\r'+ isDash c = c == '-' || c == '.'+ isInlineSpace c = c == '\t' || c == ' '+++--------------------------------------------------------------------------------+parseMetadata :: String -> Either Yaml.ParseException Metadata+parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack+++--------------------------------------------------------------------------------+parsePage :: String -> Either Yaml.ParseException (Metadata, String)+parsePage fileContent = case mbMetaBlock of+ Nothing -> return (mempty, content)+ Just metaBlock -> case parseMetadata metaBlock of+ Left err -> Left err+ Right meta -> return (meta, content)+ where+ !(!mbMetaBlock, !content) = splitMetadata fileContent+++--------------------------------------------------------------------------------+-- | Thrown in the IO monad if things go wrong. Provides a nice-ish error+-- message.+data MetadataException = MetadataException FilePath Yaml.ParseException+++--------------------------------------------------------------------------------+instance Exception MetadataException+++--------------------------------------------------------------------------------+instance Show MetadataException where+ show (MetadataException fp err) =+ fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint++ where+ hint = case err of+ Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))+ | yamlProblem == "mapping values are not allowed in this context" -> "\n" +++ "Hint: if the metadata value contains characters such\n" +++ "as ':' or '-', try enclosing it in quotes."+ Yaml.AesonException "Error in $: parsing HashMap ~Text failed, expected Object, but encountered String"+ -> "\nHint: in metadata, keys and values are separated by a colon *and* a space."+ _ -> ""
+ lib/Hakyll/Core/Provider/MetadataCache.hs view
@@ -0,0 +1,74 @@+--------------------------------------------------------------------------------+module Hakyll.Core.Provider.MetadataCache+ ( resourceMetadata+ , resourceBody+ , resourceLookupMetadataCache+ , resourceInvalidateMetadataCache+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (unless)+import Data.Maybe (fromMaybe)+import Hakyll.Core.Identifier+import Hakyll.Core.Metadata+import Hakyll.Core.Provider.Internal+import Hakyll.Core.Provider.Metadata+import qualified Hakyll.Core.Store as Store+++--------------------------------------------------------------------------------+resourceMetadata :: Provider -> Identifier -> IO Metadata+resourceMetadata p r+ | not (resourceExists p r) = return mempty+ | otherwise = do+ -- TODO keep time in md cache+ load p r+ fromMaybe mempty <$> resourceLookupMetadataCache p r+++--------------------------------------------------------------------------------+resourceBody :: Provider -> Identifier -> IO String+resourceBody p r = do+ load p r+ Store.Found bd <- Store.get (providerStore p)+ [name, toFilePath r, "body"]+ maybe (resourceString p r) return bd+++--------------------------------------------------------------------------------+-- | Perform a lookup for metadata in the cache only.+-- Useful internally for invalidation.+resourceLookupMetadataCache :: Provider -> Identifier -> IO (Maybe Metadata)+resourceLookupMetadataCache p r = do+ result <- Store.get (providerStore p) [name, toFilePath r, "metadata"]+ pure $ case result of+ Store.Found (BinaryMetadata m) -> Just m+ Store.NotFound -> Nothing+ Store.WrongType _ _ -> error "unexpected WrongType"+++--------------------------------------------------------------------------------+resourceInvalidateMetadataCache :: Provider -> Identifier -> IO ()+resourceInvalidateMetadataCache p r = do+ Store.delete (providerStore p) [name, toFilePath r, "metadata"]+ Store.delete (providerStore p) [name, toFilePath r, "body"]+++--------------------------------------------------------------------------------+load :: Provider -> Identifier -> IO ()+load p r = do+ mmof <- Store.isMember store mdk+ unless mmof $ do+ (md, body) <- loadMetadata p r+ Store.set store mdk (BinaryMetadata md)+ Store.set store bk body+ where+ store = providerStore p+ mdk = [name, toFilePath r, "metadata"]+ bk = [name, toFilePath r, "body"]+++--------------------------------------------------------------------------------+name :: String+name = "Hakyll.Core.Resource.Provider.MetadataCache"
+ lib/Hakyll/Core/Routes.hs view
@@ -0,0 +1,356 @@+--------------------------------------------------------------------------------+{- | 'Routes' is part of the 'Hakyll.Core.Rules.Rules' processing pipeline.+It determines if and where the compilation result of the underlying+'Hakyll.Core.Item.Item' being processed is written out to+(relative to the destination directory as configured in+'Hakyll.Core.Configuration.destinationDirectory').++* __If there is no route for an item, the compiled item won't be written__+__out to a file__ and so won't appear in the destination (site) directory.++* If an item matches multiple routes, the first route will be chosen.++__Examples__++Suppose we have a markdown file @posts\/hakyll.md@. We can route its+compilation result to @posts\/hakyll.html@ using 'setExtension':++> -- file on disk: '<project-directory>/posts/hakyll.md'+> match "posts/*" $ do+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+> compile pandocCompiler+Hint: You can configure the destination directory with+'Hakyll.Core.Configuration.destinationDirectory'.++If we do not want to change the extension, we can replace 'setExtension' with+'idRoute' (the simplest route available):++> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute++That will route the file @posts\/hakyll.md@ from the project directory to+@posts\/hakyll.md@ in the destination directory.++Note:+__The extension of the destination filepath says nothing about the content!__+If you set the extension to @.html@, you have to ensure that the+compilation result is indeed HTML (for example with the+'Hakyll.Web.Pandoc.pandocCompiler' to transform Markdown to HTML).++Take a look at the built-in routes here for detailed usage examples.+-}+{-# LANGUAGE Rank2Types #-}+module Hakyll.Core.Routes+ ( Routes+ , UsedMetadata+ , runRoutes+ , idRoute+ , setExtension+ , matchRoute+ , customRoute+ , constRoute+ , gsubRoute+ , metadataRoute+ , composeRoutes+ ) where+++--------------------------------------------------------------------------------+import System.FilePath (replaceExtension, normalise)+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Metadata+import Hakyll.Core.Provider+import Hakyll.Core.Util.String+++--------------------------------------------------------------------------------+-- | When you ran a route, it's useful to know whether or not this used+-- metadata. This allows us to do more granular dependency analysis.+type UsedMetadata = Bool+++--------------------------------------------------------------------------------+data RoutesRead = RoutesRead+ { routesProvider :: Provider+ , routesUnderlying :: Identifier+ }+++--------------------------------------------------------------------------------+-- | Type used for a route+newtype Routes = Routes+ { unRoutes :: RoutesRead -> Identifier -> IO (Maybe FilePath, UsedMetadata)+ }+++--------------------------------------------------------------------------------+instance Semigroup Routes where+ (<>) (Routes f) (Routes g) = Routes $ \p id' -> do+ (mfp, um) <- f p id'+ case mfp of+ Nothing -> g p id'+ Just _ -> return (mfp, um)++instance Monoid Routes where+ mempty = Routes $ \_ _ -> return (Nothing, False)+ mappend = (<>)+++--------------------------------------------------------------------------------+-- | Apply a route to an identifier+runRoutes :: Routes -> Provider -> Identifier+ -> IO (Maybe FilePath, UsedMetadata)+runRoutes routes provider identifier =+ unRoutes routes (RoutesRead provider identifier) identifier+++--------------------------------------------------------------------------------+{- | An "identity" route that interprets the identifier (of the item being+processed) as the destination filepath. This identifier is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route when using match__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute+>+> compile getResourceBody+-}+idRoute :: Routes+idRoute = customRoute toFilePath+++--------------------------------------------------------------------------------+{- | Create a route like 'idRoute' that interprets the identifier (of the item+being processed) as the destination filepath but also sets (or replaces) the+extension suffix of that path. This identifier is normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route with an existing extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+>+> compile pandocCompiler++__Route without an existing extension__++> -- implicitly gets identifier: 'about'+> create ["about"] $ do+>+> -- compilation result is written to '<destination-directory>/about.html'+> route (setExtension "html")+>+> compile $ makeItem ("Hello world" :: String)+-}+setExtension :: String -> Routes+setExtension extension = customRoute $+ (`replaceExtension` extension) . toFilePath+++--------------------------------------------------------------------------------+-- | Apply the route if the identifier matches the given pattern, fail+-- otherwise+matchRoute :: Pattern -> Routes -> Routes+matchRoute pattern (Routes route) = Routes $ \p id' ->+ if matches pattern id' then route p id' else return (Nothing, False)+++--------------------------------------------------------------------------------+{- | Create a route where the destination filepath is built with the given+construction function. The provided identifier for that function is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route that appends a custom extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md.html'+> route $ customRoute ((<> ".html") . toFilePath)+>+> compile pandocCompiler+Note that the last part of the destination filepath becomes @.md.html@+-}+customRoute :: (Identifier -> FilePath) -- ^ Destination filepath construction function+ -> Routes -- ^ Resulting route+customRoute f = Routes $ const $ \id' -> return (Just (f id'), False)+++--------------------------------------------------------------------------------+{- | Create a route that writes the compiled item to the given destination+filepath (ignoring any identifier or other data about the item being processed).+Warning: you should __use a specific destination path only for a single file in__+__a single compilation rule__. Otherwise it's unclear which of the contents+should be written to that route.++=== __Examples__+__Route to a specific filepath__++> -- implicitly gets identifier: 'main' (ignored on next line)+> create ["main"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route $ constRoute "index.html"+>+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+-}+constRoute :: FilePath -> Routes+constRoute = customRoute . const+++--------------------------------------------------------------------------------+{- | Create a "substituting" route that searches for substrings (in the+underlying identifier) that match the given pattern and transforms them+according to the given replacement function.+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath. It's normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++Hint: The name "gsub" comes from a similar function in+[R](https://www.r-project.org) and can be read as "globally substituting"+(globally in the Unix sense of repeated, not just once).++=== __Examples__+__Route that replaces part of the filepath__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/haskell/hakyll.md'+> route $ gsubRoute "posts/" (const "haskell/")+>+> compile getResourceBody+Note that "posts\/" is replaced with "haskell\/" in the destination filepath.++__Route that removes part of the filepath__++> -- implicitly gets identifier: 'tags/rss/bar.xml'+> create ["tags/rss/bar.xml"] $ do+>+> -- compilation result is written to '<destination-directory>/tags/bar.xml'+> route $ gsubRoute "rss/" (const "")+>+> compile ...+Note that "rss\/" is removed from the destination filepath.+-}+gsubRoute :: String -- ^ Pattern to repeatedly match against in the underlying identifier+ -> (String -> String) -- ^ Replacement function to apply to the matched substrings+ -> Routes -- ^ Resulting route+gsubRoute pattern replacement = customRoute $+ normalise . replaceAll pattern (replacement . removeWinPathSeparator) . removeWinPathSeparator . toFilePath+ where+ -- Filepaths on Windows containing `\\' will trip Regex matching, which+ -- is used in replaceAll. We normalise filepaths to have '/' as a path separator+ -- using removeWinPathSeparator+++--------------------------------------------------------------------------------+{- | Wrapper function around other route construction functions to get+access to the metadata (of the underlying item being processed) and use that for+the destination filepath construction.+Warning: you have to+__ensure that the accessed metadata fields actually exist__.++=== __Examples__+__Route that uses a custom slug markdown metadata field__++To create a search engine optimized yet human-readable url, we can introduce+a [slug](https://en.wikipedia.org/wiki/Clean_URL#Slug) metadata field to our+files, e.g. like in the following Markdown file: 'posts\/hakyll.md'++> ---+> title: Hakyll Post+> slug: awesome-post+> ...+> ---+> In this blog post we learn about Hakyll ...++Then we can construct a route whose destination filepath is based on that field:++> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/awesome-post.html'+> route $ metadataRoute $ \meta ->+> constRoute $ fromJust (lookupString "slug" meta) <> ".html"+>+> compile pandocCompiler+Note how we wrap 'metadataRoute' around the 'constRoute' function and how the+slug is looked up from the markdown field to construct the destination filepath.+You can use helper functions like 'Hakyll.Core.Metadata.lookupString' to access+a specific metadata field.+-}+metadataRoute :: (Metadata -> Routes) -- ^ Wrapped route construction function+ -> Routes -- ^ Resulting route+metadataRoute f = Routes $ \r i -> do+ metadata <- resourceMetadata (routesProvider r) (routesUnderlying r)+ unRoutes (f metadata) r i+++--------------------------------------------------------------------------------+{- | Compose two routes where __the first route is applied before the second__.+So @f \`composeRoutes\` g@ is more or less equivalent with @g . f@.++Warning: If the first route fails (e.g. when using 'matchRoute'), Hakyll will+not apply the second route (if you need Hakyll to try the second route,+use '<>' on 'Routes' instead).++=== __Examples__+__Route that applies two transformations__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/hakyll.html'+> route $ gsubRoute "posts/" (const "") `composeRoutes` setExtension "html"+>+> compile pandocCompiler+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath.+See 'Hakyll.Core.Identifier.Identifier' for details.+Note how we first remove the "posts\/" substring from that destination filepath+ with 'gsubRoute' and then replace the extension with 'setExtension'.+-}+composeRoutes :: Routes -- ^ First route to apply+ -> Routes -- ^ Second route to apply+ -> Routes -- ^ Resulting route+composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do+ (mfp, um) <- f p i+ case mfp of+ Nothing -> return (Nothing, um)+ Just fp -> do+ (mfp', um') <- g p (fromFilePath fp)+ return (mfp', um || um')
+ lib/Hakyll/Core/Rules.hs view
@@ -0,0 +1,495 @@+--------------------------------------------------------------------------------+-- | This module provides a declarative Domain Specific Language (DSL) to+-- generate a static site by specifying transformation 'Rules' (although the+-- use case is not limited to static sites).+-- Each rule normally consists of three parts:+-- +-- 1. Source files (like Markdown files) to process (collected with e.g.+-- 'match' or 'create').+-- 2. Compilation steps (like Markdown to HTML) to transform files' content+-- to some output content (steps are collected within +-- 'Hakyll.Core.Compiler.Compiler' and executed with 'compile').+-- 3. Routing to determine if and where an output content will be written out. +-- For a static site this determines under which URL the output content will +-- be available (configured with 'route' and 'Hakyll.Core.Routes.Routes').+-- +-- A typical usage example looks as follows:+-- +-- > -- write 'match "posts/**.md"' instead of 'match $ fromGlob "posts/**.md"'+-- > {-# LANGUAGE OverloadedStrings #-} +-- > ...+-- >+-- > main = hakyll $ do+-- >+-- > -- Rule 1+-- > -- Source files: all Markdown files like 'hakyll.md' in the 'posts' directory+-- > match "posts/**.md" $ do +-- > -- Routing: Only replace extension, so '<destination-directory>/posts/hakyll.html'.+-- > route $ setExtension "html" +-- > -- Compilation step(s): Transform Markdown file content into HTML output.+-- > compile pandocCompiler +-- >+-- > -- Rule 2+-- > match "css/*" $ do+-- > route idRoute+-- > compile compressCssCompiler+-- > ...+-- __The order of rules doesn't matter.__ +-- +-- See official [Hakyll Rules tutorial](https://jaspervdj.be/hakyll/tutorials/03-rules-routes-compilers.html)+-- for other examples.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Core.Rules+ ( Rules+ , match+ , matchMetadata+ , create+ , version+ , compile+ , route++ -- * Advanced usage+ , preprocess+ , Dependency (..)+ , rulesExtraDependencies+ ) where+++--------------------------------------------------------------------------------+import Control.Monad.Reader (ask, local)+import Control.Monad.State (get, modify, put)+import Control.Monad.Trans (liftIO)+import Control.Monad.Writer (censor, tell)+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+++--------------------------------------------------------------------------------+import Data.Binary (Binary)+import Data.Typeable (Typeable)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item+import Hakyll.Core.Item.SomeItem+import Hakyll.Core.Metadata+import Hakyll.Core.Routes+import Hakyll.Core.Rules.Internal+import Hakyll.Core.Writable+++--------------------------------------------------------------------------------+-- | Add a route+tellRoute :: Routes -> Rules ()+tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty+++--------------------------------------------------------------------------------+-- | Add a number of compilers+tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()+tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty+++--------------------------------------------------------------------------------+-- | Add resources+tellResources :: [Identifier] -> Rules ()+tellResources resources' = Rules $ tell $+ RuleSet mempty mempty (S.fromList resources') mempty+++--------------------------------------------------------------------------------+-- | Add a pattern+tellPattern :: Pattern -> Rules ()+tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern+++--------------------------------------------------------------------------------+flush :: Rules ()+flush = Rules $ do+ mcompiler <- rulesCompiler <$> get+ case mcompiler of+ Nothing -> return ()+ Just compiler -> do+ matches' <- rulesMatches <$> ask+ version' <- rulesVersion <$> ask+ route' <- fromMaybe mempty . rulesRoute <$> get++ -- The version is possibly not set correctly at this point (yet)+ let ids = map (setVersion version') matches'++ {-+ ids <- case fromLiteral pattern of+ Just id' -> return [setVersion version' id']+ Nothing -> do+ ids <- unRules $ getMatches pattern+ unRules $ tellResources ids+ return $ map (setVersion version') ids+ -}++ -- Create a fast pattern for routing that matches exactly the+ -- compilers created in the block given to match+ let fastPattern = fromList ids++ -- Write out the compilers and routes+ unRules $ tellRoute $ matchRoute fastPattern route'+ unRules $ tellCompilers $ [(id', compiler) | id' <- ids]++ put $ emptyRulesState+++--------------------------------------------------------------------------------+matchInternal :: Pattern -> Rules [Identifier] -> Rules () -> Rules ()+matchInternal pattern getIDs rules = do+ tellPattern pattern+ flush+ ids <- getIDs+ tellResources ids+ Rules $ local (setMatches ids) $ unRules $ rules >> flush+ where+ setMatches ids env = env {rulesMatches = ids}++--------------------------------------------------------------------------------+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\))) to the+given remaining 'Rules' value.++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to the+'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load' it+within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__++__Select all markdown files within a directory (but without subdirectories)__++> -- Match all Markdown files in the immediate 'posts' directory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- but NOT '<project-directory>/posts/haskell/monad.md'+> match "posts/*.md" $ do+> route $ setExtension "html"+> compile pandocCompiler++__Select all markdown files within a directory (including subdirectories recursively)__++> -- Match all Markdown files in the 'posts' directory and any subdirectory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- and '<project-directory>/posts/haskell/monad.md'+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile pandocCompiler+See 'Hakyll.Core.Identifier.Pattern.Pattern' or search "glob patterns" online+for more details. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+match :: Pattern -- ^ Glob pattern+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result+match pattern = matchInternal pattern $ getMatches pattern+++--------------------------------------------------------------------------------+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\)) and+metadata predicate) to the given remaining 'Rules' values. Same as 'match' but+allows to filter files further based on their (metadata) content (a file is+added only when the metadata predicate returns @True@).++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to+the 'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load'+it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Select all markdown files with enabled draft flag within a directory__++> matchMetadata "posts/*.md" (\meta -> maybe False (=="true") $ lookupString "draft" meta) $ do+> route $ setExtension "html"+> compile pandocCompiler++For example, the following 'posts/hakyll.md' file with @draft: true@ metadata+would match:++> ---+> draft: true+> title: Hakyll Post+> ...+> ---+> In this blog post we learn about Hakyll ...+Note that files that have @draft: false@ or no such draft field at all, would+not match. You can use helper functions like 'Hakyll.Core.Metadata.lookupString'+to access a specific metadata field, and 'Data.Maybe.maybe' to work with+'Data.Maybe.Maybe'. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+matchMetadata :: Pattern -- ^ Glob pattern+ -> (Metadata -> Bool) -- ^ Metadata predicate+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result+matchMetadata pattern metadataPred = matchInternal pattern $+ map fst . filter (metadataPred . snd) <$> getAllMetadata pattern+++--------------------------------------------------------------------------------+{- | Assign (and thereby create) the given identifier(s) to content that has no+underlying source file on disk. That content must be created within the+'compile' part of the given remaining 'Rules' value. The given identifier is the+id under which the compilation is saved to the 'Hakyll.Core.Store.Store' (in+case you want to 'Hakyll.Core.Compiler.load' it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this function for example to create an overview page that doesn't have or+need its content prepared in a file (unlike blog posts which normally have a+corresponding Markdown source file on disk).++=== __Examples__+__Create a webpage without an underlying source file__++> -- saved with implicit identifier 'index.html' to Store+> create ["index.html"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route idRoute+>+> -- create content without a source file from disk+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+Note how you can use 'Hakyll.Core.Compiler.makeItem' to create content inline+(to be processed as a 'Hakyll.Core.Compiler.Compiler' value) as if that content+was loaded from a file (as it's the case when using 'match').+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute'.+-}+create :: [Identifier] -- ^ Identifiers to assign to created content in next argument+ -> Rules () -- ^ Remaining processing parts that must create content+ -> Rules () -- ^ Resulting rule+create ids rules = do+ flush+ -- TODO Maybe check if the resources exist and call tellResources on that+ Rules $ local setMatches $ unRules $ rules >> flush+ where+ setMatches env = env {rulesMatches = ids}+++--------------------------------------------------------------------------------+{- | Add the given version name to the implicit identifier(s) under which the+compilation result of the given remaining 'Rules' value is saved to the+'Hakyll.Core.Store.Store'.+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this wrapper function for example when you need to compile the same source+file into two or more different results, each with a different version name.+The version is needed to distinguish between these different compilation results+in the store, otherwise they would get the same conflicting identifier in the+store.++Warning:+__If you add a version name with this function, you need to supply the same name__+when you 'Hakyll.Core.Compiler.load' the content from the store from+within another rule.++=== __Examples__+__Compile source file into differently versioned outputs and load both__++> -- e.g. file on disk: 'posts/hakyll.md'+>+> -- saved with implicit identifier ('posts/hakyll.md', no-version)+> match "posts/*" $ do+> route $ setExtension "html"+> compile pandocCompiler+>+> -- saved with implicit identifier ('posts/hakyll.md', version 'raw')+> match "posts/*" $ version "raw" $ do+> route idRoute+> compile getResourceBody+>+> -- use compilation results from rules above+> create ["index.html"] $ do+> route idRoute+> compile $ do+> -- load no-version version+> compiledPost <- load (fromFilePath "posts/hakyll.md")+> -- load version 'raw'+> rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md"+> ...+Note how a version name is needed to distinguish the unversioned and the "raw"+version when loading the Hakyll post for the @index.html@ page.+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute' and 'Hakyll.Core.Routes.setExtension'.+-}+version :: String -- ^ Version name to add+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result+version v rules = do+ flush+ Rules $ local setVersion' $ unRules $ rules >> flush+ where+ setVersion' env = env {rulesVersion = Just v}+++--------------------------------------------------------------------------------+{- | Add (or replace) the given compilation steps within the given+'Hakyll.Core.Compiler.Compiler' value to the current 'Rules' value.+__This functions controls HOW the content within a rule is processed__ (use one+of the 'match' functions to control WHAT content is processed).++The compilation result is saved to the 'Hakyll.Core.Store.Store' under an+implicit identifier.+See 'Hakyll.Core.Identifier.Identifier' for details.++If there's routing attached to the rule where this function is used, the+compilation result is also written out to a file according to that route.+See 'route' and 'Hakyll.Core.Routes.Routes' for details.++=== __Examples__+__Compile Markdown to HTML__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+>+> route $ setExtension "html"+>+> -- use pandoc to transform Markdown to HTML in a single step+> compile pandocCompiler+Note how we set the content to be processed with+'Hakyll.Web.Pandoc.pandocCompiler'. The content comes implicitly from the+matched Markdown files on disk. We don't have to pass that content around+manually. Every file is processed the same way within this one rule.++To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.setExtension'.+Here the compilation result of a file like @posts\/hakyll.md@ is written out+to @posts\/hakyll.html@.++__Compile Markdown to HTML and embed it in a template__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $+> pandocCompiler >>=+> loadAndApplyTemplate "templates/post.html" defaultContext+>+> -- To Hakyll templates are just plain files that have to be processed+> -- and placed into the store like any other file (but without routing).+> -- e.g. file on disk: 'templates/post.html'+> match "templates/*" $ compile templateBodyCompiler+Note how a Markdown post that is compiled to HTML using+'Hakyll.Web.Pandoc.pandocCompiler' in a first step and then embedded into+a HTMl 'Hakyll.Web.Template.Template' in a second step by using+'Hakyll.Web.Template.loadAndApplyTemplate'.+We can use templates to control the design and layout of a webpage.+A template may look as follows:++> <h1>$title$</h1>+> $body$+See "Hakyll.Web.Template" to see examples of the templating syntax.+-}+compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -- ^ How to transform content+ -> Rules () -- ^ Result+compile compiler = Rules $ modify $ \s ->+ s {rulesCompiler = Just (fmap SomeItem compiler)}+++--------------------------------------------------------------------------------+{- | Add (or replace) routing in the current 'Rules' value.+__This functions controls IF and WHERE the compiled results are written out__+(use one of the 'match' functions to control WHAT content is processed and+'compile' to control HOW).+See 'Hakyll.Core.Routes.Routes' and 'Hakyll.Core.Identifier.Identifier' for+details on how output filepaths are computed.++Hint:+__If there's no route attached to a rule, the compilation result is not written out__.+However, the compilation result is saved to the 'Hakyll.Core.Store.Store'+and can be loaded and used within another rule. This behavior is needed,+for example, for templates.++=== __Examples__+__Rules with and without routing__++> -- e.g. file on disk: 'templates/post.html'+>+> -- Rule 1 (without routing)+> match "templates/*" $ do+> -- compilation result saved to store with implicit identifier, e.g. 'templates/post.html'+> compile templateCompiler+>+> -- Rule 2 (with routing)+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $ do+> -- load compiled result of other rule with explicit identifier.+> postTemplate <- loadBody "templates/post.html"+> pandocCompiler >>= applyTemplate postTemplate defaultContext+Note that we don't set a route in the first rule to avoid writing out our+compiled templates.+However, we can still 'Hakyll.Core.Compiler.load' (or+'Hakyll.Core.Compiler.loadBody') the compiled templates to apply them in a+second rule.+The content for 'Hakyll.Web.Template.templateCompiler' comes implicitly from the+matched template files on disk. We don't have to pass that content around+manually. See 'match' and 'compile' for details.++To control where a compilation result will be written out (as done in the second+rule), use routing functions like 'Hakyll.Core.Routes.setExtension'.++See "Hakyll.Web.Template" for examples of templates and the templating syntax.+-}+route :: Routes -- ^ Where to output compilation results+ -> Rules () -- ^ Result+route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'}+++--------------------------------------------------------------------------------+-- | Execute an 'IO' action immediately while the rules are being evaluated.+-- This should be avoided if possible, but occasionally comes in useful.+preprocess :: IO a -> Rules a+preprocess = Rules . liftIO+++--------------------------------------------------------------------------------+-- | Advanced usage: add extra dependencies to compilers. Basically this is+-- needed when you're doing unsafe tricky stuff in the rules monad, but you+-- still want correct builds.+--+-- A useful utility for this purpose is 'makePatternDependency'.+rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a+rulesExtraDependencies deps rules =+ -- Note that we add the dependencies seemingly twice here. However, this is+ -- done so that 'rulesExtraDependencies' works both if we have something+ -- like:+ --+ -- > match "*.css" $ rulesExtraDependencies [foo] $ ...+ --+ -- and something like:+ --+ -- > rulesExtraDependencies [foo] $ match "*.css" $ ...+ --+ -- (1) takes care of the latter and (2) of the former.+ Rules $ censor fixRuleSet $ do+ x <- unRules rules+ fixCompiler+ return x+ where+ -- (1) Adds the dependencies to the compilers we are yet to create+ fixCompiler = modify $ \s -> case rulesCompiler s of+ Nothing -> s+ Just c -> s+ { rulesCompiler = Just $ compilerTellDependencies deps >> c+ }++ -- (2) Adds the dependencies to the compilers that are already in the ruleset+ fixRuleSet ruleSet = ruleSet+ { rulesCompilers =+ [ (i, compilerTellDependencies deps >> c)+ | (i, c) <- rulesCompilers ruleSet+ ]+ }
+ lib/Hakyll/Core/Rules/Internal.hs view
@@ -0,0 +1,116 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+module Hakyll.Core.Rules.Internal+ ( RulesRead (..)+ , RuleSet (..)+ , RulesState (..)+ , emptyRulesState+ , Rules (..)+ , runRules+ ) where+++--------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Control.Monad.Reader (ask)+import Control.Monad.RWS (RWST, runRWST)+import Control.Monad.Trans (liftIO)+import qualified Data.Map as M+import Data.Set (Set)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item.SomeItem+import Hakyll.Core.Metadata+import Hakyll.Core.Provider+import Hakyll.Core.Routes+++--------------------------------------------------------------------------------+data RulesRead = RulesRead+ { rulesProvider :: Provider+ , rulesMatches :: [Identifier]+ , rulesVersion :: Maybe String+ }+++--------------------------------------------------------------------------------+data RuleSet = RuleSet+ { -- | Accumulated routes+ rulesRoutes :: Routes+ , -- | Accumulated compilers+ rulesCompilers :: [(Identifier, Compiler SomeItem)]+ , -- | A set of the actually used files+ rulesResources :: Set Identifier+ , -- | A pattern we can use to check if a file *would* be used. This is+ -- needed for the preview server.+ rulesPattern :: Pattern+ }+++--------------------------------------------------------------------------------+instance Semigroup RuleSet where+ (<>) (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =+ RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)++instance Monoid RuleSet where+ mempty = RuleSet mempty mempty mempty mempty+ mappend = (<>)+++--------------------------------------------------------------------------------+data RulesState = RulesState+ { rulesRoute :: Maybe Routes+ , rulesCompiler :: Maybe (Compiler SomeItem)+ }+++--------------------------------------------------------------------------------+emptyRulesState :: RulesState+emptyRulesState = RulesState Nothing Nothing+++--------------------------------------------------------------------------------+-- | The monad used to compose rules+newtype Rules a = Rules+ { unRules :: RWST RulesRead RuleSet RulesState IO a+ } deriving (Monad, MonadFail, Functor, Applicative)+++--------------------------------------------------------------------------------+instance MonadMetadata Rules where+ getMetadata identifier = Rules $ do+ provider <- rulesProvider <$> ask+ liftIO $ resourceMetadata provider identifier++ getMatches pattern = Rules $ do+ provider <- rulesProvider <$> ask+ return $ filterMatches pattern $ resourceList provider+++--------------------------------------------------------------------------------+-- | Run a Rules monad, resulting in a 'RuleSet'+runRules :: Rules a -> Provider -> IO RuleSet+runRules rules provider = do+ (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState++ -- Ensure compiler uniqueness+ let ruleSet' = ruleSet+ { rulesCompilers = M.toList $+ M.fromListWith (flip const) (rulesCompilers ruleSet)+ }++ return ruleSet'+ where+ env = RulesRead+ { rulesProvider = provider+ , rulesMatches = []+ , rulesVersion = Nothing+ }
+ lib/Hakyll/Core/Runtime.hs view
@@ -0,0 +1,539 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+module Hakyll.Core.Runtime+ ( run+ , RunMode(..)+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO, getNumCapabilities,+ rtsSupportsBoundThreads)+import qualified Control.Concurrent.MVar as MVar+import Control.Exception (SomeException, try)+import Control.Monad (replicateM_, unless, void, when)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans (liftIO)+import Data.Foldable (for_, traverse_)+import qualified Data.Graph as Graph+import Data.IORef (IORef)+import qualified Data.IORef as IORef+import Data.List (intercalate)+#if !(MIN_VERSION_base(4,20,0))+import Data.List (foldl')+#endif+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Compiler.Require+import Hakyll.Core.Configuration+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Item+import Hakyll.Core.Item.SomeItem+import Hakyll.Core.Logger (Logger)+import qualified Hakyll.Core.Logger as Logger+import Hakyll.Core.Provider+import Hakyll.Core.Routes+import Hakyll.Core.Rules.Internal+import Hakyll.Core.Store (Store)+import qualified Hakyll.Core.Store as Store+import Hakyll.Core.Util.File+import Hakyll.Core.Writable+++factsKey :: [String]+factsKey = ["Hakyll.Core.Runtime.run", "facts"]+++--------------------------------------------------------------------------------+-- | Whether to execute a normal run (build the site) or a dry run.+data RunMode = RunModeNormal | RunModePrintOutOfDate+ deriving (Show)+++--------------------------------------------------------------------------------+run :: RunMode -> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)+run mode config logger rules = do+ -- Initialization+ Logger.header logger "Initialising..."+ Logger.message logger "Creating store..."+ store <- Store.new (inMemoryCache config) $ storeDirectory config+ Logger.message logger "Creating provider..."+ (provider, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $+ providerDirectory config+ Logger.message logger "Running rules..."+ ruleSet <- runRules rules provider++ -- Get old facts+ mOldFacts <- Store.get store factsKey+ let (oldFacts) = case mOldFacts of Store.Found f -> f+ _ -> mempty++ -- Build runtime read/state+ scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts}+ let compilers = rulesCompilers ruleSet+ read' = RuntimeRead+ { runtimeConfiguration = config+ , runtimeLogger = logger+ , runtimeProvider = provider+ , runtimeModifiedMeta = Set.fromList modifiedMeta+ , runtimeStore = store+ , runtimeRoutes = rulesRoutes ruleSet+ , runtimeUniverse = Map.fromList compilers+ , runtimeScheduler = scheduler+ }++ -- Run the program and fetch the resulting state+ runReaderT (build mode) read'+ errors <- schedulerErrors <$> IORef.readIORef scheduler+ if null errors then do+ Logger.debug logger "Removing tmp directory..."+ removeDirectory $ tmpDirectory config++ Logger.flush logger+ return (ExitSuccess, ruleSet)+ else do+ for_ errors $ \(mbId, err) -> Logger.error logger $ case mbId of+ Just identifier -> show identifier <> ": " <> err+ Nothing -> err+ Logger.flush logger+ return (ExitFailure 1, ruleSet)+++--------------------------------------------------------------------------------+data RuntimeRead = RuntimeRead+ { runtimeConfiguration :: Configuration+ , runtimeLogger :: Logger+ , runtimeProvider :: Provider+ , runtimeModifiedMeta :: Set Identifier+ , runtimeStore :: Store+ , runtimeRoutes :: Routes+ , runtimeUniverse :: Map Identifier (Compiler SomeItem)+ , runtimeScheduler :: IORef Scheduler+ }+++--------------------------------------------------------------------------------+-- | A Scheduler is a pure representation of work going on, works that needs+-- to be done, and work already done. Workers can obtain things to do+-- by interacting with the Scheduler, and execute them synchronously or+-- asynchronously.+--+-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and+-- should be used with atomicModifyIORef'.+data Scheduler = Scheduler+ { -- | Items to work on next. Identifiers may appear multiple times.+ schedulerQueue :: !(Seq Identifier)+ , -- | Items that we haven't started yet.+ schedulerTodo :: !(Map Identifier (Compiler SomeItem))+ , -- | Currently processing+ schedulerWorking :: !(Set Identifier)+ , -- | Finished+ schedulerDone :: !(Set Identifier)+ , -- | Any snapshots stored.+ schedulerSnapshots :: !(Set (Identifier, Snapshot))+ , -- | Any routed files and who wrote them. This is used to detect multiple+ -- writes to the same file, which can yield inconsistent results.+ schedulerRoutes :: !(Map FilePath Identifier)+ , -- | Currently blocked compilers.+ schedulerBlocked :: !(Set Identifier)+ , -- | Compilers that may resume on triggers+ schedulerTriggers :: !(Map Identifier (Set Identifier))+ , -- | Number of starved pops; tracking this allows us to start a new+ -- number of threads again later.+ schedulerStarved :: !Int+ , -- | Dynamic dependency info.+ schedulerFacts :: !DependencyFacts+ , -- | Errors encountered.+ schedulerErrors :: ![(Maybe Identifier, String)]+ }+++--------------------------------------------------------------------------------+emptyScheduler :: Scheduler+emptyScheduler = Scheduler {..}+ where+ schedulerTodo = Map.empty+ schedulerDone = Set.empty+ schedulerQueue = Seq.empty+ schedulerWorking = Set.empty+ schedulerSnapshots = Set.empty+ schedulerRoutes = Map.empty+ schedulerBlocked = Set.empty+ schedulerTriggers = Map.empty+ schedulerStarved = 0+ schedulerFacts = Map.empty+ schedulerErrors = []+++--------------------------------------------------------------------------------+schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ())+schedulerError i e s = (s {schedulerErrors = (i, e) : schedulerErrors s}, ())+++--------------------------------------------------------------------------------+schedulerMarkOutOfDate+ :: Map Identifier (Compiler SomeItem)+ -> Set Identifier+ -> Set Identifier+ -> Scheduler+ -> (Scheduler, [String])+schedulerMarkOutOfDate universe modifiedC modifiedM scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo)+ , schedulerDone = schedulerDone <>+ (Map.keysSet universe `Set.difference` ood)+ , schedulerTodo = schedulerTodo <> todo+ , schedulerFacts = facts'+ }+ , msgs+ )+ where+ (ood, facts', msgs) = outOfDate (Map.keys universe) modifiedC modifiedM schedulerFacts+ todo = Map.filterWithKey (\id' _ -> id' `Set.member` ood) universe+++--------------------------------------------------------------------------------+data SchedulerStep+ -- | The scheduler instructs to offer some work on the given item. It+ -- also returns the number of threads that can be resumed after they have+ -- starved.+ = SchedulerWork Identifier (Compiler SomeItem) Int+ -- | There's currently no work available, but there will be after other+ -- threads have finished whatever they are doing.+ | SchedulerStarve+ -- | We've finished all work.+ | SchedulerFinish+ -- | An error occurred. You can retrieve the errors from 'schedulerErrors'.+ | SchedulerError+++--------------------------------------------------------------------------------+schedulerPop :: Scheduler -> (Scheduler, SchedulerStep)+schedulerPop scheduler@Scheduler {..} = case Seq.viewl schedulerQueue of+ Seq.EmptyL+ | not $ Set.null schedulerWorking ->+ ( scheduler {schedulerStarved = schedulerStarved + 1}+ , SchedulerStarve+ )+ | not $ Set.null schedulerBlocked ->+ let cycles = schedulerCycles scheduler+ msg | null cycles = "Possible dependency cycle in: " <>+ intercalate ", " (show <$> Set.toList schedulerBlocked)+ | otherwise = "Dependency cycles: " <>+ intercalate "; "+ (map (intercalate " -> " . map show) cycles) in+ SchedulerError <$ schedulerError Nothing msg scheduler+ | otherwise -> (scheduler, SchedulerFinish)+ x Seq.:< xs+ | x `Set.member` schedulerDone ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerWorking ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerBlocked ->+ schedulerPop scheduler {schedulerQueue = xs}+ | otherwise -> case Map.lookup x schedulerTodo of+ Nothing -> SchedulerError <$+ schedulerError (Just x) "Compiler not found" scheduler+ Just c ->+ ( scheduler+ { schedulerQueue = xs+ , schedulerWorking = Set.insert x schedulerWorking+ }+ , SchedulerWork x c 0+ )+++--------------------------------------------------------------------------------+schedulerCycles :: Scheduler -> [[Identifier]]+schedulerCycles Scheduler {..} =+ [c | Graph.CyclicSCC c <- Graph.stronglyConnComp graph]+ where+ graph = [(x, x, Set.toList ys) | (x, ys) <- Map.toList edges]+ edges = Map.fromListWith Set.union $ do+ (dep, xs) <- Map.toList $ schedulerTriggers+ x <- Set.toList xs+ pure (x, Set.singleton dep)+++--------------------------------------------------------------------------------+schedulerBlock+ :: Identifier+ -> [(Identifier, Snapshot)]+ -> Compiler SomeItem+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerBlock identifier deps0 compiler scheduler@Scheduler {..}+ | null deps1 = (scheduler, SchedulerWork identifier compiler 0)+ | otherwise = schedulerPop $ scheduler+ { schedulerQueue =+ -- Optimization: move deps to the front and item to the back+ Seq.fromList depIds <>+ schedulerQueue <>+ Seq.singleton identifier+ , schedulerTodo =+ Map.insert identifier+ (Compiler $ \_ -> pure $ CompilerRequire deps0 compiler)+ schedulerTodo+ , schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerBlocked = Set.insert identifier schedulerBlocked+ , schedulerTriggers = foldl'+ (\acc (depId, _) ->+ Map.insertWith Set.union depId (Set.singleton identifier) acc)+ schedulerTriggers+ deps1+ }+ where+ deps1 = filter (not . done) deps0+ depIds = map fst deps1++ -- Done if we either completed the entire item (runtimeDone) or+ -- if we previously saved the snapshot (runtimeSnapshots).+ done (depId, depSnapshot) =+ depId `Set.member` schedulerDone ||+ (depId, depSnapshot) `Set.member` schedulerSnapshots+++--------------------------------------------------------------------------------+schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int)+schedulerUnblock identifier scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue =+ schedulerQueue <> Seq.fromList (Set.toList triggered)+ , schedulerStarved = 0+ , schedulerBlocked = Set.delete identifier $+ schedulerBlocked `Set.difference` triggered+ , schedulerTriggers = Map.delete identifier schedulerTriggers+ }+ , schedulerStarved+ )+ where+ triggered = fromMaybe Set.empty $ Map.lookup identifier schedulerTriggers+++--------------------------------------------------------------------------------+schedulerSnapshot+ :: Identifier -> Snapshot -> Compiler SomeItem+ -> Scheduler -> (Scheduler, SchedulerStep)+schedulerSnapshot identifier snapshot compiler scheduler@Scheduler {..} =+ let (scheduler', resume) = schedulerUnblock identifier scheduler+ { schedulerSnapshots =+ Set.insert (identifier, snapshot) schedulerSnapshots+ } in+ (scheduler', SchedulerWork identifier compiler resume)+++--------------------------------------------------------------------------------+schedulerWrite+ :: Identifier+ -> [Dependency]+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerWrite identifier depFacts scheduler0@Scheduler {..} =+ let (scheduler1, resume) = schedulerUnblock identifier scheduler0+ { schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerFacts = Map.insert identifier depFacts schedulerFacts+ , schedulerDone =+ Set.insert identifier schedulerDone+ , schedulerTodo =+ Map.delete identifier schedulerTodo+ }+ (scheduler2, step) = schedulerPop scheduler1 in+ case step of+ SchedulerWork i c n -> (scheduler2, SchedulerWork i c (n + resume))+ _ -> (scheduler2, step)+++--------------------------------------------------------------------------------+-- | Record that a specific identifier was routed to a specific filepath.+-- This is used to detect multiple (inconsistent) writes to the same file.+schedulerRoute+ :: Identifier+ -> FilePath+ -> Scheduler+ -> (Scheduler, ())+schedulerRoute id0 path scheduler0@Scheduler {..}+ | Just id1 <- Map.lookup path schedulerRoutes, id0 /= id1 =+ let msg = "multiple writes for route " ++ path ++ ": " +++ show id0 ++ " and " ++ show id1 in+ schedulerError (Just id0) msg scheduler0+ | otherwise =+ let routes = Map.insert path id0 schedulerRoutes in+ (scheduler0 {schedulerRoutes = routes}, ())+++--------------------------------------------------------------------------------+build :: RunMode -> ReaderT RuntimeRead IO ()+build mode = do+ logger <- runtimeLogger <$> ask+ Logger.header logger "Checking for out-of-date items"+ schedulerRef <- runtimeScheduler <$> ask+ scheduleOutOfDate+ case mode of+ RunModeNormal -> do+ Logger.header logger "Compiling"+ if rtsSupportsBoundThreads then pickAndChaseAsync else pickAndChase+ errs <- liftIO $ schedulerErrors <$> IORef.readIORef schedulerRef+ when (null errs) $ Logger.header logger "Success"+ facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef+ store <- runtimeStore <$> ask+ liftIO $ Store.set store factsKey facts+ RunModePrintOutOfDate -> do+ Logger.header logger "Out of date items:"+ todo <- liftIO $ schedulerTodo <$> IORef.readIORef schedulerRef+ traverse_ (Logger.message logger . show) (Map.keys todo)+++--------------------------------------------------------------------------------+scheduleOutOfDate :: ReaderT RuntimeRead IO ()+scheduleOutOfDate = do+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ modifiedMeta <- runtimeModifiedMeta <$> ask+ universe <- runtimeUniverse <$> ask+ schedulerRef <- runtimeScheduler <$> ask+ let modifiedContent = Set.filter (resourceModified provider) (Map.keysSet universe)+ msgs <- liftIO . IORef.atomicModifyIORef' schedulerRef $+ schedulerMarkOutOfDate universe modifiedContent modifiedMeta++ -- Print messages+ mapM_ (Logger.debug logger) msgs+++--------------------------------------------------------------------------------+pickAndChase :: ReaderT RuntimeRead IO ()+pickAndChase = do+ scheduler <- runtimeScheduler <$> ask+ let go SchedulerFinish = pure ()+ go SchedulerError = pure ()+ go (SchedulerWork i c _) = work i c >>= go+ go SchedulerStarve =+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError Nothing "Starved, possible dependency cycle?"+ pop <- liftIO . IORef.atomicModifyIORef' scheduler $ schedulerPop+ go pop+++--------------------------------------------------------------------------------+pickAndChaseAsync :: ReaderT RuntimeRead IO ()+pickAndChaseAsync = do+ runtimeRead <- ask+ numThreads <- liftIO getNumCapabilities+ let scheduler = runtimeScheduler runtimeRead+ Logger.message (runtimeLogger runtimeRead) $+ "Using async runtime with " <> show numThreads <> " threads..."+ liftIO $ do+ signal <- MVar.newEmptyMVar++ let spawnN :: Int -> IO ()+ spawnN n = replicateM_ n $ forkIO $+ IORef.atomicModifyIORef' scheduler schedulerPop >>= go++ go :: SchedulerStep -> IO ()+ go step = case step of+ SchedulerFinish -> void $ MVar.tryPutMVar signal ()+ SchedulerStarve -> pure ()+ SchedulerError -> void $ MVar.tryPutMVar signal ()+ (SchedulerWork i c n) -> do+ spawnN n+ step' <- runReaderT (work i c) runtimeRead+ go step'++ spawnN numThreads+ MVar.readMVar signal+++--------------------------------------------------------------------------------+work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep+work id' compiler = do+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ universe <- runtimeUniverse <$> ask+ routes <- runtimeRoutes <$> ask+ store <- runtimeStore <$> ask+ config <- runtimeConfiguration <$> ask+ scheduler <- runtimeScheduler <$> ask++ let cread = CompilerRead+ { compilerConfig = config+ , compilerUnderlying = id'+ , compilerProvider = provider+ , compilerUniverse = Map.keysSet universe+ , compilerRoutes = routes+ , compilerStore = store+ , compilerLogger = logger+ }+ result <- liftIO $ runCompiler compiler cread+ case result of+ CompilerError e -> do+ let msgs = case compilerErrorMessages e of+ [] -> ["Compiler failed but no info given, try running with -v?"]+ es -> es+ for_ msgs $ \msg -> liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') msg+ return SchedulerError++ CompilerSnapshot snapshot c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerSnapshot id' snapshot c++ CompilerDone (SomeItem item) cwrite -> do+ -- Print some info+ let facts = compilerDependencies cwrite+ cacheHits+ | compilerCacheHits cwrite <= 0 = "updated"+ | otherwise = "cached "+ Logger.message logger $ cacheHits ++ " " ++ show id'++ -- Sanity check+ liftIO . unless (itemIdentifier item == id') $+ IORef.atomicModifyIORef' scheduler $ schedulerError+ (Just id') $+ "The compiler yielded an Item with Identifier " +++ show (itemIdentifier item) ++ ", but we were expecting " +++ "an Item with Identifier " ++ show id' ++ " " +++ "(you probably want to call makeItem to solve this problem)"++ -- Write if necessary. Note that we want another exception handler+ -- around this: some compilers may successfully produce a+ -- 'CompilerResult', but the thing they are supposed to 'write' can+ -- have an un-evaluated 'error' them.+ routeOrErr <- liftIO $ try $ do+ (mroute, _) <- runRoutes routes provider id'+ for_ mroute $ \route -> do+ IORef.atomicModifyIORef' scheduler $+ schedulerRoute id' route+ let path = destinationDirectory config </> route+ makeDirectories path+ write path item+ save store item+ pure mroute++ case routeOrErr of+ Left e -> do+ liftIO $ IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') $+ "An exception was thrown when persisting " +++ "the compiler result: " ++ show (e :: SomeException)+ pure SchedulerError+ Right mroute -> do+ for_ mroute $ \route ->+ Logger.debug logger $ "Routed to " ++ show route+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerWrite id' facts++ CompilerRequire reqs c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerBlock id' reqs c
+ lib/Hakyll/Core/Store.hs view
@@ -0,0 +1,233 @@+--------------------------------------------------------------------------------+-- | A store for storing and retreiving items+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Hakyll.Core.Store+ ( Store+ , Result (..)+ , toMaybe+ , new+ , set+ , get+ , isMember+ , delete+ , hash+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (when)+import Data.Binary (Binary, decode, encodeFile)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Cache.LRU.IO as Lru+import qualified Data.Hashable as DH+import qualified Data.IORef as IORef+import Data.List (intercalate)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Typeable (TypeRep, Typeable, cast, typeOf)+import System.Directory (createDirectoryIfMissing, doesFileExist,+ removeFile)+import System.FilePath ((</>))+import System.IO (IOMode (..), hClose, openFile)+import System.IO.Error (catchIOError, ioeSetFileName,+ ioeSetLocation, modifyIOError)+++--------------------------------------------------------------------------------+-- | Simple wrapper type+data Box = forall a. Typeable a => Box a+++--------------------------------------------------------------------------------+data Store = Store+ { -- | All items are stored on the filesystem+ storeDirectory :: FilePath+ , -- | See 'set'+ storeWriteAhead :: IORef.IORef (Map.Map String Box)+ -- | Optionally, items are also kept in-memory+ , storeMap :: Maybe (Lru.AtomicLRU FilePath Box)+ }+++--------------------------------------------------------------------------------+instance Show Store where+ show _ = "<Store>"+++--------------------------------------------------------------------------------+-- | Result of a store query+data Result a+ = Found a -- ^ Found, result+ | NotFound -- ^ Not found+ | WrongType TypeRep TypeRep -- ^ Expected, true type+ deriving (Show, Eq)+++--------------------------------------------------------------------------------+-- | Convert result to 'Maybe'+toMaybe :: Result a -> Maybe a+toMaybe (Found x) = Just x+toMaybe _ = Nothing+++--------------------------------------------------------------------------------+-- | Initialize the store+new :: Bool -- ^ Use in-memory caching+ -> FilePath -- ^ Directory to use for hard disk storage+ -> IO Store -- ^ Store+new inMemory directory = do+ createDirectoryIfMissing True directory+ writeAhead <- IORef.newIORef Map.empty+ ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing+ return Store+ { storeDirectory = directory+ , storeWriteAhead = writeAhead+ , storeMap = ref+ }+ where+ csize = Just 500++--------------------------------------------------------------------------------+withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a+withStore store loc run identifier = modifyIOError handle $ run key path+ where+ key = hash identifier+ path = storeDirectory store </> key+ handle e = e `ioeSetFileName` (path ++ " for " ++ intercalate "/" identifier)+ `ioeSetLocation` ("Store." ++ loc)++--------------------------------------------------------------------------------+-- | Auxiliary: add an item to the in-memory cache+cacheInsert :: Typeable a => Store -> String -> a -> IO ()+cacheInsert (Store _ _ Nothing) _ _ = return ()+cacheInsert (Store _ _ (Just lru)) key x =+ Lru.insert key (Box x) lru+++--------------------------------------------------------------------------------+-- | Auxiliary: get an item from the in-memory cache+cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)+cacheLookup (Store _ _ Nothing) _ = return NotFound+cacheLookup (Store _ _ (Just lru)) key = do+ res <- Lru.lookup key lru+ return $ case res of+ Nothing -> NotFound+ Just (Box x) -> case cast x of+ Just x' -> Found x'+ Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)+++--------------------------------------------------------------------------------+cacheIsMember :: Store -> String -> IO Bool+cacheIsMember (Store _ _ Nothing) _ = return False+cacheIsMember (Store _ _ (Just lru)) key = isJust <$> Lru.lookup key lru+++--------------------------------------------------------------------------------+-- | Auxiliary: delete an item from the in-memory cache+cacheDelete :: Store -> String -> IO ()+cacheDelete (Store _ _ Nothing) _ = return ()+cacheDelete (Store _ _ (Just lru)) key = do+ _ <- Lru.delete key lru+ return ()+++--------------------------------------------------------------------------------+-- | Store an item+set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()+set store identifier value = withStore store "set" (\key path -> do+ -- We need to avoid concurrent writes to the filesystem. Imagine the+ -- follow scenario:+ --+ -- * We compile multiple posts+ -- * All of these fetch some common metadata+ -- * This metadata is missing; we fetch it and then store it.+ --+ -- To solve this, we skip duplicate writes by tracking their status+ -- in 'storeWriteAhead'. Since this set will usually be small, the+ -- required locking should be fast. Additionally the actual IO operation+ -- still happens outside of the locking.+ first <- IORef.atomicModifyIORef' (storeWriteAhead store) $+ \wa -> case Map.lookup key wa of+ Nothing -> (Map.insert key (Box value) wa, True)+ Just _ -> (wa, False)++ cacheInsert store key value++ -- Only the thread that stored the writeAhead should actually write this+ -- file. That way, only one thread at a time will try to write this.+ -- Release the writeAhead value once we're done.+ when first $ do+ encodeFile path value+ IORef.atomicModifyIORef' (storeWriteAhead store) $+ \wa -> (Map.delete key wa, ())+ ) identifier+++--------------------------------------------------------------------------------+-- | Load an item+get :: forall a. (Binary a, Typeable a) => Store -> [String] -> IO (Result a)+get store = withStore store "get" $ \key path -> do+ -- Check the writeAhead value+ writeAhead <- IORef.readIORef $ storeWriteAhead store+ case Map.lookup key writeAhead of+ Just (Box x) -> case cast x of+ Just x' -> pure $ Found x'+ Nothing -> pure $ WrongType (typeOf (undefined :: a)) (typeOf x)+ Nothing -> do+ -- Check the in-memory map+ ref <- cacheLookup store key+ case ref of+ -- Not found in the map, try the filesystem+ NotFound -> do+ exists <- doesFileExist path+ if not exists+ -- Not found in the filesystem either+ then return NotFound+ -- Found in the filesystem+ else do+ v <- decodeClose path+ cacheInsert store key v+ return $ Found v+ -- Found in the in-memory map (or wrong type), just return+ s -> return s+ where+ -- 'decodeFile' from Data.Binary which closes the file ASAP+ decodeClose path = do+ h <- openFile path ReadMode+ lbs <- BL.hGetContents h+ BL.length lbs `seq` hClose h+ return $ decode lbs+++--------------------------------------------------------------------------------+-- | Strict function+isMember :: Store -> [String] -> IO Bool+isMember store = withStore store "isMember" $ \key path -> do+ writeAhead <- IORef.readIORef $ storeWriteAhead store+ if Map.member key writeAhead+ then pure True+ else do+ inCache <- cacheIsMember store key+ if inCache then return True else doesFileExist path+++--------------------------------------------------------------------------------+-- | Delete an item+delete :: Store -> [String] -> IO ()+delete store = withStore store "delete" $ \key path -> do+ cacheDelete store key+ deleteFile path+++--------------------------------------------------------------------------------+-- | Delete a file unless it doesn't exist...+deleteFile :: FilePath -> IO ()+deleteFile = (`catchIOError` \_ -> return ()) . removeFile+++--------------------------------------------------------------------------------+-- | Mostly meant for internal usage+hash :: [String] -> String+hash = show . DH.hash . intercalate "/"
+ lib/Hakyll/Core/UnixFilter.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- | A Compiler that supports unix filters.+module Hakyll.Core.UnixFilter+ ( unixFilter+ , unixFilterLBS+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.DeepSeq (deepseq)+import Control.Monad (forM_)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.IORef (newIORef, readIORef, writeIORef)+import System.Exit (ExitCode (..))+import System.IO (Handle, hClose, hFlush, hGetContents,+ hPutStr, hSetEncoding, localeEncoding)+import System.Process++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+++--------------------------------------------------------------------------------+-- | Use a unix filter as compiler. For example, we could use the 'rev' program+-- as a compiler.+--+-- > rev :: Compiler (Item String)+-- > rev = getResourceString >>= withItemBody (unixFilter "rev" [])+--+-- A more realistic example: one can use this to call, for example, the sass+-- compiler on CSS files. More information about sass can be found here:+--+-- <http://sass-lang.com/>+--+-- The code is fairly straightforward, given that we use @.scss@ for sass:+--+-- > match "style.scss" $ do+-- > route $ setExtension "css"+-- > compile $ getResourceString >>=+-- > withItemBody (unixFilter "sass" ["-s", "--scss"]) >>=+-- > return . fmap compressCss+unixFilter :: String -- ^ Program name+ -> [String] -- ^ Program args+ -> String -- ^ Program input+ -> Compiler String -- ^ Program output+unixFilter = unixFilterWith writer reader+ where+ writer handle input = do+ hSetEncoding handle localeEncoding+ hPutStr handle input+ reader handle = do+ hSetEncoding handle localeEncoding+ out <- hGetContents handle+ deepseq out (return out)+++--------------------------------------------------------------------------------+-- | Variant of 'unixFilter' that should be used for binary files+--+-- > match "music.wav" $ do+-- > route $ setExtension "ogg"+-- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"])+unixFilterLBS :: String -- ^ Program name+ -> [String] -- ^ Program args+ -> ByteString -- ^ Program input+ -> Compiler ByteString -- ^ Program output+unixFilterLBS = unixFilterWith LB.hPutStr $ \handle -> do+ out <- LB.hGetContents handle+ LB.length out `seq` return out+++--------------------------------------------------------------------------------+-- | Overloaded compiler+unixFilterWith :: Monoid o+ => (Handle -> i -> IO ()) -- ^ Writer+ -> (Handle -> IO o) -- ^ Reader+ -> String -- ^ Program name+ -> [String] -- ^ Program args+ -> i -- ^ Program input+ -> Compiler o -- ^ Program output+unixFilterWith writer reader programName args input = do+ debugCompiler ("Executing external program " ++ programName)+ (output, err, exitCode) <- unsafeCompiler $+ unixFilterIO writer reader programName args input+ forM_ (lines err) debugCompiler+ case exitCode of+ ExitSuccess -> return output+ ExitFailure e -> fail $+ "Hakyll.Core.UnixFilter.unixFilterWith: " +++ unwords (programName : args) ++ " gave exit code " ++ show e +++ ". (Error: " ++ err ++ ")"+++--------------------------------------------------------------------------------+-- | Internally used function+unixFilterIO :: Monoid o+ => (Handle -> i -> IO ())+ -> (Handle -> IO o)+ -> String+ -> [String]+ -> i+ -> IO (o, String, ExitCode)+unixFilterIO writer reader programName args input = do+ -- The problem on Windows is that `proc` is unable to execute+ -- batch stubs (eg. anything created using 'gem install ...') even if its in+ -- `$PATH`. A solution to this issue is to execute the batch file explicitly+ -- using `cmd /c batchfile` but there is no rational way to know where said+ -- batchfile is on the system. Hence, we detect windows using the+ -- CPP and instead of using `proc` to create the process, use `shell`+ -- which will be able to execute everything `proc` can+ -- as well as batch files.+#ifdef mingw32_HOST_OS+ let pr = shell $ unwords (programName : args)+#else+ let pr = proc programName args+#endif++ (Just inh, Just outh, Just errh, pid) <-+ createProcess pr+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ -- Create boxes+ lock <- newEmptyMVar+ outRef <- newIORef mempty+ errRef <- newIORef ""++ -- Write the input to the child pipe+ _ <- forkIO $ writer inh input >> hFlush inh >> hClose inh++ -- Read from stdout+ _ <- forkIO $ do+ out <- reader outh+ hClose outh+ writeIORef outRef out+ putMVar lock ()++ -- Read from stderr+ _ <- forkIO $ do+ hSetEncoding errh localeEncoding+ err <- hGetContents errh+ _ <- deepseq err (return err)+ hClose errh+ writeIORef errRef err+ putMVar lock ()++ -- Get exit code & return+ takeMVar lock+ takeMVar lock+ exitCode <- waitForProcess pid+ out <- readIORef outRef+ err <- readIORef errRef+ return (out, err, exitCode)
+ lib/Hakyll/Core/Util/File.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+-- | A module containing various file utility functions+module Hakyll.Core.Util.File+ ( makeDirectories+ , getRecursiveContents+ , removeDirectory+ , withPermissions+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (throw)+import Control.Monad (filterM, forM)+import System.Directory (createDirectoryIfMissing, doesPathExist,+ doesDirectoryExist, getDirectoryContents)+import System.FilePath (takeDirectory, (</>))+import System.IO.Error (catchIOError, isPermissionError)+#ifndef mingw32_HOST_OS+import Control.Monad (when)+import System.Directory (removeDirectoryRecursive)+#else+import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, catch)+import System.Directory (removePathForcibly)+#endif+++--------------------------------------------------------------------------------+-- | Given a path to a file, try to make the path writable by making+-- all directories on the path.+makeDirectories :: FilePath -> IO ()+makeDirectories = createDirectoryIfMissing True . takeDirectory+++--------------------------------------------------------------------------------+-- | Get all contents of a directory.+--+-- If a directory is encountered for which you do not have+-- permission, the directory will be skipped instead of+-- an exception being thrown.+--+-- If a dangling\/broken symbolic link is encountered, then it will+-- be skipped (since returning it may cause callers to throw exceptions).+getRecursiveContents :: (FilePath -> IO Bool) -- ^ Ignore this file/directory+ -> FilePath -- ^ Directory to search+ -> IO [FilePath] -- ^ List of files found for which you have permissions+getRecursiveContents ignore top = go ""+ where+ isProper x+ | x `elem` [".", ".."] = return False+ | otherwise = not <$> ignore x++ getProperDirectoryContents absDir =+ filterM isProper =<< withPermissions (getDirectoryContents absDir) []++ go relDir = do+ let absDir = top </> relDir+ dirExists <- doesDirectoryExist absDir+ if not dirExists+ then return []+ else do+ names <- getProperDirectoryContents absDir+ fmap concat . forM names $ \name -> do+ let relPath = relDir </> name+ absPath = top </> relPath+ isDirectory <- doesDirectoryExist absPath+ if isDirectory+ then go relPath+ else do+ pathExists <- doesPathExist absPath+ return $ if pathExists then [relPath] else []+++--------------------------------------------------------------------------------+removeDirectory :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+removeDirectory fp = do+ e <- doesDirectoryExist fp+ when e $ removeDirectoryRecursive fp+#else+-- Deleting files on Windows is unreliable. If a file/directory is open by a program (e.g. antivirus),+-- then removing related directories *quickly* may fail with strange messages.+-- See here for discussions:+-- https://github.com/haskell/directory/issues/96+-- https://github.com/haskell/win32/pull/129+--+-- The hacky solution is to retry deleting directories a few times,+-- with a delay, on Windows only.+removeDirectory = retryWithDelay 10 . removePathForcibly++--------------------------------------------------------------------------------+-- | Retry an operation at most /n/ times (/n/ must be positive).+-- If the operation fails the /n/th time it will throw that final exception.+-- A delay of 100ms is introduced between every retry.+retryWithDelay :: Int -> IO a -> IO a+retryWithDelay i x+ | i <= 0 = error "Hakyll.Core.Util.File.retry: retry count must be 1 or more"+ | i == 1 = x+ | otherwise = catch x $ \(_::SomeException) -> threadDelay 100 >> retryWithDelay (i-1) x+#endif++--------------------------------------------------------------------------------+-- | Perform an IO action, catching any permission errors and returning+-- a default value in their place. All other exceptions are rethrown.+withPermissions :: IO a+ -> a -- ^ Default value to return in case of a permission error+ -> IO a+withPermissions act onError+ = act `catchIOError` \e ->+ if isPermissionError e+ then pure onError+ else throw e
+ lib/Hakyll/Core/Util/Parser.hs view
@@ -0,0 +1,31 @@+--------------------------------------------------------------------------------+-- | Parser utilities+module Hakyll.Core.Util.Parser+ ( metadataKey+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<|>))+import Control.Monad (guard, mzero, void)+import qualified Text.Parsec as P+import Text.Parsec.String (Parser)+++--------------------------------------------------------------------------------+metadataKey :: Parser String+metadataKey = do+ -- Ensure trailing '-' binds to '$' if present.+ let hyphon = P.try $ do+ void $ P.char '-'+ x <- P.lookAhead P.anyChar+ guard $ x /= '$'+ pure '-'++ i <- (:) <$> P.letter <*> P.many (P.alphaNum <|> P.oneOf "_." <|> hyphon)+ if i `elem` reservedKeys then mzero else return i+++--------------------------------------------------------------------------------+reservedKeys :: [String]+reservedKeys = ["if", "else", "endif", "for", "sep", "endfor", "partial"]
+ lib/Hakyll/Core/Util/String.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- | Miscellaneous string manipulation functions.+module Hakyll.Core.Util.String+ ( trim+ , replaceAll+ , splitAll+ , needlePrefix+ , removeWinPathSeparator+ ) where+++--------------------------------------------------------------------------------+import Data.Char (isSpace)+import Data.List (isPrefixOf)+import Text.Regex.TDFA ((=~~))+++--------------------------------------------------------------------------------+-- | Trim a string (drop spaces, tabs and newlines at both sides).+trim :: String -> String+trim = reverse . trim' . reverse . trim'+ where+ trim' = dropWhile isSpace+++--------------------------------------------------------------------------------+-- | A simple (but inefficient) regex replace funcion+replaceAll :: String -- ^ Pattern+ -> (String -> String) -- ^ Replacement (called on match)+ -> String -- ^ Source string+ -> String -- ^ Result+replaceAll pattern f source = replaceAll' source+ where+ replaceAll' "" = ""+ replaceAll' src = case src =~~ pattern of+ Nothing -> src+ Just (before, capture, after) -> before ++ f capture ++ replaceAll' after+++--------------------------------------------------------------------------------+-- | A simple regex split function. The resulting list will contain no empty+-- strings.+splitAll :: String -- ^ Pattern+ -> String -- ^ String to split+ -> [String] -- ^ Result+splitAll pattern = filter (not . null) . splitAll'+ where+ splitAll' "" = []+ splitAll' src = case src =~~ pattern of+ Nothing -> [src]+ Just (before, _::String, after) -> before : splitAll' after++++--------------------------------------------------------------------------------+-- | Find the first instance of needle (must be non-empty) in haystack. We+-- return the prefix of haystack before needle is matched.+--+-- Examples:+--+-- > needlePrefix "cd" "abcde" = "ab"+--+-- > needlePrefix "ab" "abc" = ""+--+-- > needlePrefix "ab" "xxab" = "xx"+--+-- > needlePrefix "a" "xx" = "xx"+needlePrefix :: String -> String -> Maybe String+needlePrefix needle haystack = go [] haystack+ where+ go _ [] = Nothing+ go acc xss@(x:xs)+ | needle `isPrefixOf` xss = Just $ reverse acc+ | otherwise = go (x : acc) xs+++--------------------------------------------------------------------------------+-- | Translate native Windows path separators '\\' to '/' if present.+removeWinPathSeparator :: String -> String+removeWinPathSeparator = concatMap (\c -> if c == '\\' then ['/'] else [c])
+ lib/Hakyll/Core/Writable.hs view
@@ -0,0 +1,56 @@+--------------------------------------------------------------------------------+-- | Describes writable items; items that can be saved to the disk+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Hakyll.Core.Writable+ ( Writable (..)+ ) where+++--------------------------------------------------------------------------------+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.Word (Word8)+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.String (renderHtml)+++--------------------------------------------------------------------------------+import Hakyll.Core.Item+++--------------------------------------------------------------------------------+-- | Describes an item that can be saved to the disk+class Writable a where+ -- | Save an item to the given filepath+ write :: FilePath -> Item a -> IO ()+++--------------------------------------------------------------------------------+instance Writable () where+ write _ _ = return ()+++--------------------------------------------------------------------------------+instance Writable [Char] where+ write p = writeFile p . itemBody+++--------------------------------------------------------------------------------+instance Writable SB.ByteString where+ write p = SB.writeFile p . itemBody+++--------------------------------------------------------------------------------+instance Writable LB.ByteString where+ write p = LB.writeFile p . itemBody+++--------------------------------------------------------------------------------+instance Writable [Word8] where+ write p = write p . fmap SB.pack+++--------------------------------------------------------------------------------+instance Writable Html where+ write p = write p . fmap renderHtml
+ lib/Hakyll/Main.hs view
@@ -0,0 +1,203 @@+--------------------------------------------------------------------------------+-- | Module providing the main hakyll function and command-line argument parsing+module Hakyll.Main+ ( -- * Entry points+ hakyll+ , hakyllWith+ , hakyllWithArgs+ , hakyllWithExitCode+ , hakyllWithExitCodeAndArgs++ -- * Command line argument parsers+ , Options(..)+ , Command(..)+ , optionParser+ , commandParser+ , defaultCommands+ , defaultParser+ , defaultParserPure+ , defaultParserPrefs+ , defaultParserInfo+ ) where+++--------------------------------------------------------------------------------+import System.Environment (getProgName)+import System.Exit (ExitCode (ExitSuccess), exitWith)+import System.IO.Unsafe (unsafePerformIO)+++--------------------------------------------------------------------------------+import qualified Options.Applicative as OA+++--------------------------------------------------------------------------------+import qualified Hakyll.Check as Check+import qualified Hakyll.Commands as Commands+import qualified Hakyll.Core.Configuration as Config+import qualified Hakyll.Core.Logger as Logger+import Hakyll.Core.Rules+import Hakyll.Core.Runtime+++--------------------------------------------------------------------------------+-- | This usually is the function with which the user runs the hakyll compiler+hakyll :: Rules a -> IO ()+hakyll = hakyllWith Config.defaultConfiguration++--------------------------------------------------------------------------------+-- | A variant of 'hakyll' which allows the user to specify a custom+-- configuration+hakyllWith :: Config.Configuration -> Rules a -> IO ()+hakyllWith conf rules = hakyllWithExitCode conf rules >>= exitWith++--------------------------------------------------------------------------------+-- | A variant of 'hakyll' which returns an 'ExitCode'+hakyllWithExitCode :: Config.Configuration -> Rules a -> IO ExitCode+hakyllWithExitCode conf rules = do+ args <- defaultParser conf+ hakyllWithExitCodeAndArgs conf args rules++--------------------------------------------------------------------------------+-- | A variant of 'hakyll' which expects a 'Configuration' and command-line+-- 'Options'. This gives freedom to implement your own parsing.+hakyllWithArgs :: Config.Configuration -> Options -> Rules a -> IO ()+hakyllWithArgs conf args rules =+ hakyllWithExitCodeAndArgs conf args rules >>= exitWith++--------------------------------------------------------------------------------+hakyllWithExitCodeAndArgs :: Config.Configuration ->+ Options -> Rules a -> IO ExitCode+hakyllWithExitCodeAndArgs conf args rules = do+ let args' = optCommand args+ verbosity' = if verbosity args then Logger.Debug else Logger.Message+ check =+ if internal_links args' then Check.InternalLinks else Check.All++ logger <- Logger.new verbosity'+ invokeCommands args' conf check logger rules++--------------------------------------------------------------------------------+defaultParser :: Config.Configuration -> IO Options+defaultParser conf =+ OA.customExecParser defaultParserPrefs (defaultParserInfo conf)+++--------------------------------------------------------------------------------+defaultParserPure :: Config.Configuration -> [String] -> OA.ParserResult Options+defaultParserPure conf =+ OA.execParserPure defaultParserPrefs (defaultParserInfo conf)+++--------------------------------------------------------------------------------+defaultParserPrefs :: OA.ParserPrefs+defaultParserPrefs = OA.prefs OA.showHelpOnError++--------------------------------------------------------------------------------+defaultParserInfo :: Config.Configuration -> OA.ParserInfo Options+defaultParserInfo conf =+ OA.info (OA.helper <*> optionParser conf) (OA.fullDesc <> OA.progDesc (+ progName ++ " - Static site compiler created with Hakyll"))++--------------------------------------------------------------------------------+invokeCommands :: Command -> Config.Configuration ->+ Check.Check -> Logger.Logger -> Rules a -> IO ExitCode+invokeCommands args conf check logger rules =+ case args of+ Build mode -> Commands.build mode conf logger rules+ Check _ -> Commands.check conf logger check+ Clean -> Commands.clean conf logger >> ok+ Deploy -> Commands.deploy conf+ Preview p -> Commands.preview conf logger rules p >> ok+ Rebuild -> Commands.rebuild conf logger rules+ Server _ _ -> Commands.server conf logger (host args) (port args) >> ok+ Watch _ p s -> Commands.watch conf logger (host args) p (not s) rules >> ok+ where+ ok = return ExitSuccess+++--------------------------------------------------------------------------------++-- | The parsed command-line options.+data Options = Options {verbosity :: Bool, optCommand :: Command}+ deriving (Show)++-- | The command to run.+data Command+ = Build RunMode+ -- ^ Generate the site.+ | Check {internal_links :: Bool}+ -- ^ Validate the site output.+ | Clean+ -- ^ Clean up and remove cache.+ | Deploy+ -- ^ Upload/deploy your site.+ | Preview {port :: Int}+ -- ^ [DEPRECATED] Please use the watch command.+ | Rebuild+ -- ^ Clean and build again.+ | Server {host :: String, port :: Int}+ -- ^ Start a preview server.+ | Watch {host :: String, port :: Int, no_server :: Bool }+ -- ^ Autocompile on changes and start a preview server.+ deriving (Show)++{-# DEPRECATED Preview "Use Watch instead." #-}++optionParser :: Config.Configuration -> OA.Parser Options+optionParser conf = Options <$> verboseParser <*> commandParser conf+ where+ verboseParser = OA.switch (OA.long "verbose" <> OA.short 'v' <> OA.help "Run in verbose mode")+++commandParser :: Config.Configuration -> OA.Parser Command+commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty (defaultCommands conf)+ where+ produceCommand (c,a,b) = OA.command c (OA.info (OA.helper <*> a) (b))+++defaultCommands :: Config.Configuration -> [(String, OA.Parser Command, OA.InfoMod a)]+defaultCommands conf =+ [ ( "build"+ , pure Build <*> OA.flag RunModeNormal RunModePrintOutOfDate (OA.long "dry-run" <> OA.help "Don't build, only print out-of-date items")+ , OA.fullDesc <> OA.progDesc "Generate the site"+ )+ , ( "check"+ , pure Check <*> OA.switch (OA.long "internal-links" <> OA.help "Check internal links only")+ , OA.fullDesc <> OA.progDesc "Validate the site output"+ )+ , ( "clean"+ , pure Clean+ , OA.fullDesc <> OA.progDesc "Clean up and remove cache"+ )+ , ( "deploy"+ , pure Deploy+ , OA.fullDesc <> OA.progDesc "Upload/deploy your site"+ )+ , ( "preview"+ , pure Preview <*> portParser+ , OA.fullDesc <> OA.progDesc "[DEPRECATED] Please use the watch command"+ )+ , ( "rebuild"+ , pure Rebuild+ , OA.fullDesc <> OA.progDesc "Clean and build again"+ )+ , ( "server"+ , pure Server <*> hostParser <*> portParser+ , OA.fullDesc <> OA.progDesc "Start a preview server"+ )+ , ( "watch"+ , pure Watch <*> hostParser <*> portParser <*> OA.switch (OA.long "no-server" <> OA.help "Disable the built-in web server")+ , OA.fullDesc <> OA.progDesc "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server."+ )+ ]+ where+ portParser = OA.option OA.auto (OA.long "port" <> OA.help "Port to listen on" <> OA.value (Config.previewPort conf))+ hostParser = OA.strOption (OA.long "host" <> OA.help "Host to bind on" <> OA.value (Config.previewHost conf))+++--------------------------------------------------------------------------------+-- | This is necessary because not everyone calls their program the same...+progName :: String+progName = unsafePerformIO getProgName+{-# NOINLINE progName #-}
+ lib/Hakyll/Preview/Poll.hs view
@@ -0,0 +1,109 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module Hakyll.Preview.Poll+ ( watchUpdates+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar,+ tryPutMVar)+import Control.Exception (AsyncException, fromException,+ handle, throw)+import Control.Monad (forever, void, when)+import System.Directory (canonicalizePath)+import System.FilePath (pathSeparators)+import qualified System.FSNotify as FSNotify++#ifdef mingw32_HOST_OS+import Control.Concurrent (threadDelay)+import Control.Exception (IOException, try)+import System.Directory (doesFileExist)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.IO (Handle, IOMode (ReadMode),+ hClose, openFile)+import System.IO.Error (isPermissionError)+#endif+++--------------------------------------------------------------------------------+import Hakyll.Core.Configuration+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+++--------------------------------------------------------------------------------+-- | A thread that watches for updates in a 'providerDirectory' and recompiles+-- a site as soon as any changes occur+watchUpdates :: Configuration -> IO Pattern -> IO ()+watchUpdates conf update = do+ let providerDir = providerDirectory conf+ shouldBuild <- newEmptyMVar+ pattern <- update+ fullProviderDir <- canonicalizePath providerDir+ manager <- FSNotify.startManager+ checkIgnore <- shouldWatchIgnore conf++ let allowed event = do+ -- Absolute path of the changed file. This must be inside provider+ -- dir, since that's the only dir we're watching.+ let path = FSNotify.eventPath event+ relative = dropWhile (`elem` pathSeparators) $+ drop (length fullProviderDir) path+ identifier = fromFilePath relative+ shouldIgnore <- checkIgnore path+ return $ not shouldIgnore && matches pattern identifier++ -- This thread continually watches the `shouldBuild` MVar and builds+ -- whenever a value is present.+ _ <- forkIO $ forever $ do+ event <- takeMVar shouldBuild+ handle+ (\e -> case fromException e of+ Nothing -> putStrLn (show e)+ Just async -> throw (async :: AsyncException))+ (update' event providerDir)++ -- Send an event whenever something occurs so that the thread described+ -- above will do a build.+ void $ FSNotify.watchTree manager providerDir (not . isRemove) $ \event -> do+ allowed' <- allowed event+ when allowed' $ void $ tryPutMVar shouldBuild event+ where+#ifndef mingw32_HOST_OS+ update' _ _ = void update+#else+ update' event provider = do+ let path = provider </> FSNotify.eventPath event+ -- on windows, a 'Modified' event is also sent on file deletion+ fileExists <- doesFileExist path++ when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10++ -- continuously attempts to open the file in between sleep intervals+ -- handler is run only once it is able to open the file+ waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r+ waitOpen _ _ _ 0 = do+ putStrLn "[ERROR] Failed to retrieve modified file for regeneration"+ exitFailure+ waitOpen path mode handler retries = do+ res <- try $ openFile path mode :: IO (Either IOException Handle)+ case res of+ Left ex -> if isPermissionError ex+ then do+ threadDelay 100000+ waitOpen path mode handler (retries - 1)+ else throw ex+ Right h -> do+ handled <- handler h+ hClose h+ return handled+#endif+++--------------------------------------------------------------------------------+isRemove :: FSNotify.Event -> Bool+isRemove (FSNotify.Removed {}) = True+isRemove _ = False
+ lib/Hakyll/Preview/Server.hs view
@@ -0,0 +1,35 @@+--------------------------------------------------------------------------------+-- | Implements a basic static file server for previewing options+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Preview.Server+ ( staticServer+ ) where+++--------------------------------------------------------------------------------+import Data.String+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Application.Static as Static+import qualified Network.Wai as Wai+import Network.HTTP.Types.Status (Status)++--------------------------------------------------------------------------------+import Hakyll.Core.Logger (Logger)+import qualified Hakyll.Core.Logger as Logger++staticServer :: Logger -- ^ Logger+ -> Static.StaticSettings -- ^ Static file server settings+ -> String -- ^ Host to bind on+ -> Int -- ^ Port to listen on+ -> IO () -- ^ Blocks forever+staticServer logger settings host port = do+ Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port+ Logger.flush logger -- ensure this line is logged before Warp errors+ Warp.runSettings warpSettings $ Static.staticApp settings+ where+ warpSettings = Warp.setLogger noLog+ $ Warp.setHost (fromString host)+ $ Warp.setPort port Warp.defaultSettings++noLog :: Wai.Request -> Status -> Maybe Integer -> IO ()+noLog _ _ _ = return ()
+ lib/Hakyll/Web/CompressCss.hs view
@@ -0,0 +1,105 @@+--------------------------------------------------------------------------------+-- | Module used for CSS compression. The compression is currently in a simple+-- state, but would typically reduce the number of bytes by about 25%.+module Hakyll.Web.CompressCss+ ( compressCssCompiler+ , compressCss+ ) where+++--------------------------------------------------------------------------------+import Data.Char (isSpace)+import Data.List (dropWhileEnd, isPrefixOf)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Core.Util.String+++--------------------------------------------------------------------------------+-- | Compiler form of 'compressCss'+compressCssCompiler :: Compiler (Item String)+compressCssCompiler = fmap compressCss <$> getResourceString+++--------------------------------------------------------------------------------+-- | Compress CSS to speed up your site.+compressCss :: String -> String+compressCss = withoutStrings (handleCalcExpressions compressSeparators . compressWhitespace)+ . dropWhileEnd isSpace+ . dropWhile isSpace+ . stripComments+++--------------------------------------------------------------------------------+-- | Compresses certain forms of separators.+compressSeparators :: String -> String+compressSeparators =+ replaceAll "; *}" (const "}") .+ replaceAll ";+" (const ";") .+ replaceAll " *[{};,>+~!] *" (take 1 . dropWhile isSpace) .+ replaceAll ": *" (take 1) -- not destroying pseudo selectors (#323)++-- | Uses `compressExpression` on all parenthesised calc and +-- clamp expressions, and applies `transform` to all parts +-- outside of them+handleCalcExpressions :: (String -> String) -> String -> String+handleCalcExpressions transform = top transform+ where+ top f "" = f ""+ top f str | "calc(" `isPrefixOf` str = f "calc" ++ nested 0 compressExpression (drop 4 str)+ -- See issue #1021+ | "clamp(" `isPrefixOf` str = f "clamp" ++ nested 0 compressExpression (drop 5 str) + top f (x:xs) = top (f . (x:)) xs+ + -- when called with depth=0, the first character must be a '('+ nested :: Int -> (String -> String) -> String -> String+ nested _ f "" = f "" -- shouldn't happen, mismatched nesting+ nested depth f str | "calc(" `isPrefixOf` str = nested depth f (drop 4 str)+ nested 1 f (')':xs) = f ")" ++ top transform xs+ nested depth f (x:xs) = nested (case x of+ '(' -> depth + 1+ ')' -> depth - 1 -- assert: depth > 1+ _ -> depth+ ) (f . (x:)) xs++-- | does not remove whitespace around + and -, which is important +-- in calc() and clamp() expressions+compressExpression :: String -> String+compressExpression =+ replaceAll " *[*/] *| *\\)|\\( *" (take 1 . dropWhile isSpace)++--------------------------------------------------------------------------------+-- | Compresses all whitespace.+compressWhitespace :: String -> String+compressWhitespace = replaceAll "[ \t\n\r]+" (const " ")++--------------------------------------------------------------------------------+-- | Function that strips CSS comments away (outside of strings).+stripComments :: String -> String+stripComments "" = ""+stripComments ('/':'*':str) = stripComments $ eatComment str+stripComments (x:xs) | x `elem` "\"'" = retainString x xs stripComments+ | otherwise = x : stripComments xs++eatComment :: String -> String+eatComment "" = ""+eatComment ('*':'/':str) = str+eatComment (_:str) = eatComment str+++--------------------------------------------------------------------------------+-- | Helper functions to handle string tokens correctly.++-- TODO: handle backslash escapes+withoutStrings :: (String -> String) -> String -> String+withoutStrings f str = case span (`notElem` "\"'") str of+ (text, "") -> f text+ (text, d:rest) -> f text ++ retainString d rest (withoutStrings f)++retainString :: Char -> String -> (String -> String) -> String+retainString delim str cont = case span (/= delim) str of+ (val, "") -> delim : val+ (val, _:rest) -> delim : val ++ delim : cont rest
+ lib/Hakyll/Web/Feed.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++--------------------------------------------------------------------------------+-- | A Module that allows easy rendering of RSS feeds.+--+-- The main rendering functions (@renderRss@, @renderAtom@) all assume that+-- you pass the list of items so that the most recent entry in the feed is the+-- first item in the list.+--+-- Also note that the context should have (at least) the following fields to+-- produce a correct feed:+--+-- - @$title$@: Title of the item+--+-- - @$description$@: Description to appear in the feed+--+-- - @$url$@: URL to the item - this is usually set automatically.+--+-- In addition, the posts should be named according to the rules for+-- 'Hakyll.Web.Template.Context.dateField'+--+-- Note that for XML-based feeds (i.e. Atom and RSS) field values are not escaped!+-- However, the default 'renderRss' and 'renderAtom' functions will validate the+-- produced XML. Use the -NoValidate functions instead if you need to skip this+-- validation.+module Hakyll.Web.Feed+ ( FeedConfiguration (..)+ , renderRss+ , renderRssNoValidate+ , renderAtom+ , renderAtomNoValidate+ , renderJson+ , renderRssWithTemplates+ , renderRssWithTemplatesNoValidate+ , renderAtomWithTemplates+ , renderAtomWithTemplatesNoValidate+ , renderJsonWithTemplates+ , validateXMLFeed+ ) where+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal (compilerThrow)+import Hakyll.Core.Item+import Hakyll.Core.Util.String (replaceAll)+import Hakyll.Web.Template+import Hakyll.Web.Template.Context+import Hakyll.Web.Template.List+++--------------------------------------------------------------------------------+import Data.FileEmbed (makeRelativeToProject)+import System.FilePath ((</>))+import Text.Printf (printf)+import Control.Exception (displayException)+import Text.XML (parseText, def)+import qualified Data.Text.Lazy as T+++--------------------------------------------------------------------------------+rssTemplate :: Template+rssTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "rss.xml")+ >>= embedTemplate)++rssItemTemplate :: Template+rssItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "rss-item.xml")+ >>= embedTemplate)++atomTemplate :: Template+atomTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "atom.xml")+ >>= embedTemplate)++atomItemTemplate :: Template+atomItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "atom-item.xml")+ >>= embedTemplate)++jsonTemplate :: Template+jsonTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "feed.json")+ >>= embedTemplate)++jsonItemTemplate :: Template+jsonItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "feed-item.json")+ >>= embedTemplate)+++--------------------------------------------------------------------------------+-- | This is a data structure to keep the configuration of a feed.+data FeedConfiguration = FeedConfiguration+ { -- | Title of the feed.+ feedTitle :: String+ , -- | Description of the feed.+ feedDescription :: String+ , -- | Name of the feed author.+ feedAuthorName :: String+ , -- | Email of the feed author. Set this to the empty String to leave out+ -- the email address.+ feedAuthorEmail :: String+ , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@)+ feedRoot :: String+ } deriving (Show, Eq)+++--------------------------------------------------------------------------------+-- | Different types a feed can have.+data FeedType = XmlFeed | JsonFeed+ deriving (Show, Eq)+++--------------------------------------------------------------------------------+-- | Abstract function to render any feed.+renderFeed :: FeedType -- ^ Feed type+ -> Template -- ^ Default feed template+ -> Template -- ^ Default item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Context for the items+ -> [Item String] -- ^ Input items+ -> Compiler (Item String) -- ^ Resulting item+renderFeed feedType feedTpl itemTpl config itemContext items = do+ protectedItems <-+ case feedType of+ XmlFeed -> mapM (applyFilter protectCDATA) items+ JsonFeed -> pure items+ let itemDelim = case feedType of+ XmlFeed -> ""+ JsonFeed -> ", "++ body <- makeItem =<< applyJoinTemplateList itemDelim itemTpl itemContext' protectedItems+ applyTemplate feedTpl feedContext body+ where+ applyFilter :: (Monad m,Functor f) => (String -> String) -> f String -> m (f String)+ applyFilter tr str = return $ fmap tr str+ protectCDATA :: String -> String+ protectCDATA = replaceAll "]]>" (const "]]>")++ itemContext' = mconcat+ [ escapeDescription itemContext+ , constField "root" (feedRoot config)+ , constField "authorName" (feedAuthorName config)+ , emailField+ ]++ feedContext = mconcat+ [ bodyField "body"+ , constField "title" (feedTitle config)+ , constField "description" (feedDescription config)+ , constField "authorName" (feedAuthorName config)+ , emailField+ , constField "root" (feedRoot config)+ , urlField "url"+ , updatedField+ , missingField+ ]++ -- Take the first "updated" field from all items -- this should be the most+ -- recent.+ updatedField = field "updated" $ \_ -> case items of+ [] -> return "Unknown"+ (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of+ StringField s -> return s+ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"++ emailField = case feedAuthorEmail config of+ "" -> missingField+ email -> constField "authorEmail" email++ escapeDescription = case feedType of+ XmlFeed -> id+ JsonFeed -> mapContextBy (== "description") escapeString+++--------------------------------------------------------------------------------+-- | Validate that a feed contains only correct XML.+validateXMLFeed :: Item String -> Compiler (Item String)+validateXMLFeed rendered = case parseText def $ T.pack (itemBody rendered) of+ Right _ -> pure rendered+ Left err -> compilerThrow+ ["Generated feed contains invalid XML (perhaps you id not escape a metadata field?)",+ displayException err]+++--------------------------------------------------------------------------------+-- | Render an RSS feed using given templates with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderRssWithTemplates'+-- when possible.+--+-- @since 4.16.7.0+renderRssWithTemplatesNoValidate ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context = renderFeed+ XmlFeed feedTemplate itemTemplate config+ (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)+++--------------------------------------------------------------------------------+-- | Render an RSS feed using given templates with a number of items.+--+-- The resulting RSS feed will be validated automatically.+renderRssWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssWithTemplates feedTemplate itemTemplate config context items =+ renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render an Atom feed using given templates with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderAtomWithTemplates'+-- when possible.+--+-- @since 4.16.7.0+renderAtomWithTemplatesNoValidate ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items = renderFeed+ XmlFeed feedTemplate itemTemplate config+ (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)+ items+++--------------------------------------------------------------------------------+-- | Render an Atom feed using given templates with a number of items.+--+-- The resulting Atom feed will be validated automatically.+renderAtomWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomWithTemplates feedTemplate itemTemplate config context items =+ renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render a JSON feed using given templates with a number of items.+renderJsonWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderJsonWithTemplates feedTemplate itemTemplate config context = renderFeed+ JsonFeed feedTemplate itemTemplate config+ (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)+++--------------------------------------------------------------------------------+-- | Render an RSS feed with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderRss'+-- when possible.+--+-- @since 4.16.7.0+renderRssNoValidate :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssNoValidate = renderRssWithTemplatesNoValidate rssTemplate rssItemTemplate+++--------------------------------------------------------------------------------+-- | Render an RSS feed with a number of items.+--+-- The resulting RSS feed will be validated automatically.+renderRss :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRss config context items = renderRssNoValidate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render an Atom feed with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderAtom'+-- when possible.+--+-- @since 4.16.7.0+renderAtomNoValidate :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomNoValidate = renderAtomWithTemplatesNoValidate atomTemplate atomItemTemplate+++--------------------------------------------------------------------------------+-- | Render an Atom feed with a number of items.+--+-- The resulting Atom feed will be validated automatically.+renderAtom :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtom config context items = renderAtomNoValidate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render a JSON feed with a number of items.+--+-- Items' bodies will be put into @content_html@ field of the resulting JSON;+-- the @content@ field will not be set.+renderJson :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderJson = renderJsonWithTemplates jsonTemplate jsonItemTemplate+++--------------------------------------------------------------------------------+-- | Copies @$updated$@ from @$published$@ if it is not already set.+makeItemContext :: String -> Context a -> Context a+makeItemContext fmt context = mconcat+ [context, dateField "published" fmt, dateField "updated" fmt]+++--------------------------------------------------------------------------------+-- | Escape the string according to [RFC8259 §7](https://www.rfc-editor.org/rfc/rfc8259#section-7). In other words,+-- * quotation marks and backslashes are prefixed with a backslash+-- * control characters (i.e. 0x00 - 0x1F) are escaped s.t. their+-- hex representation are prefixed with "\u00" (e.g. 0x15 -> \u0015)+-- * the rest of the characters are untouched.+escapeString :: String -> String+escapeString = flip escapeString' ""+ where+ escapeString' :: String -> ShowS+ escapeString' [] s = s+ escapeString' ('"' : cs) s = showString "\\\"" (escapeString' cs s)+ escapeString' ('\\' : cs) s = showString "\\\\" (escapeString' cs s)+ escapeString' (c : cs) s+ | c < ' ' = escapeChar c (escapeString' cs s)+ | otherwise = showChar c (escapeString' cs s)++ escapeChar :: Char -> ShowS+ escapeChar = showString . printf "\\u%04X"
+ lib/Hakyll/Web/Html.hs view
@@ -0,0 +1,309 @@+--------------------------------------------------------------------------------+-- | Provides utilities to manipulate HTML pages+module Hakyll.Web.Html+ ( -- * Generic+ withTags+ , withTagList+ , withTagListM++ -- * Headers+ , demoteHeaders+ , demoteHeadersBy++ -- * Url manipulation+ , getUrls+ , withUrls+ , toUrl+ , toSiteRoot+ , isExternal++ -- * Stripping/escaping+ , stripTags+ , escapeHtml+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (void)+import Control.Monad.Identity (Identity(runIdentity))+import Data.Char (digitToInt, intToDigit,+ isDigit, toLower)+import Data.Either (fromRight)+import Data.List (isPrefixOf, intercalate)+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import System.FilePath (joinPath, splitPath,+ takeDirectory)+import Text.Blaze.Html (toHtml)+import Text.Blaze.Html.Renderer.String (renderHtml)+import qualified Text.Parsec as P+import qualified Text.Parsec.Char as PC+import qualified Text.HTML.TagSoup as TS+import Network.URI (isUnreserved, escapeURIString)+++--------------------------------------------------------------------------------+import Hakyll.Core.Util.String (removeWinPathSeparator)+++--------------------------------------------------------------------------------+-- | Map over all tags in the document+withTags :: (TS.Tag String -> TS.Tag String) -> String -> String+withTags = withTagList . map++-- | Map over all tags (as list) in the document+withTagList :: ([TS.Tag String] -> [TS.Tag String]) -> String -> String+withTagList f = runIdentity . withTagListM (pure . f)++-- | Map over all tags (as list) in the document, in a monad+withTagListM :: Monad m => ([TS.Tag String] -> m [TS.Tag String]) -> String -> m String+withTagListM f = fmap renderTags' . f . parseTags'+{-# INLINE withTagListM #-}++--------------------------------------------------------------------------------+-- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.+demoteHeaders :: String -> String+demoteHeaders = demoteHeadersBy 1++--------------------------------------------------------------------------------+-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@.+demoteHeadersBy :: Int -> String -> String+demoteHeadersBy amount+ | amount < 1 = id+ | otherwise = withTags $ \tag -> case tag of+ TS.TagOpen t a -> TS.TagOpen (demote t) a+ TS.TagClose t -> TS.TagClose (demote t)+ t -> t+ where+ demote t@['h', n]+ | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)]+ | otherwise = t+ demote t = t+++--------------------------------------------------------------------------------+isUrlAttribute :: String -> Bool+isUrlAttribute = (`elem` ["src", "href", "data", "poster"])+++--------------------------------------------------------------------------------+-- | Extract URLs from tags' attributes. Those would be the same URLs on which+-- `withUrls` would act.+getUrls :: [TS.Tag String] -> [String]+getUrls tags = [u | TS.TagOpen _ as <- tags, (k, v) <- as, u <- extractUrls k v]+ where+ extractUrls "srcset" value =+ let srcset = fmap unSrcset $ P.parse srcsetParser "" value+ in map srcsetImageCandidateUrl $ fromRight [] srcset+ extractUrls key value+ | isUrlAttribute key = [value]+ | otherwise = []+++--------------------------------------------------------------------------------+-- | Apply a function to each URL on a webpage+withUrls :: (String -> String) -> String -> String+withUrls f = withTags tag+ where+ tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a+ tag x = x++ attr input@("srcset", v) =+ case fmap unSrcset $ P.parse srcsetParser "" v of+ Right srcset ->+ let srcset' = map (\i -> i { srcsetImageCandidateUrl = f $ srcsetImageCandidateUrl i }) srcset+ srcset'' = show $ Srcset srcset'+ in ("srcset", srcset'')+ Left _ -> input+ attr (k, v) = (k, if isUrlAttribute k then f v else v)+++--------------------------------------------------------------------------------+-- | Customized TagSoup renderer. The default TagSoup renderer escape CSS+-- within style tags, and doesn't properly minimize.+renderTags' :: [TS.Tag String] -> String+renderTags' = TS.renderTagsOptions TS.RenderOptions+ { TS.optRawTag = (`elem` ["script", "style"]) . map toLower+ , TS.optMinimize = (`S.member` minimize) . map toLower+ , TS.optEscape = id+ }+ where+ -- A list of elements which must be minimized+ minimize = S.fromList+ [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"+ , "param"+ ]+++--------------------------------------------------------------------------------+-- | Customized TagSoup parser: do not decode any entities.+parseTags' :: String -> [TS.Tag String]+parseTags' = TS.parseTagsOptions (TS.parseOptions :: TS.ParseOptions String)+ { TS.optEntityData = \(str, b) -> [TS.TagText $ "&" ++ str ++ [';' | b]]+ , TS.optEntityAttrib = \(str, b) -> ("&" ++ str ++ [';' | b], [])+ }+++--------------------------------------------------------------------------------+-- | Convert a filepath to an URL starting from the site root+--+-- Example:+--+-- > toUrl "foo/bar.html"+--+-- Result:+--+-- > "/foo/bar.html"+--+-- This also sanitizes the URL, e.g. converting spaces into '%20'+toUrl :: FilePath -> String+toUrl url = case (removeWinPathSeparator url) of+ ('/' : xs) -> '/' : sanitize xs+ xs -> '/' : sanitize xs+ where+ -- Everything but unreserved characters should be escaped as we are+ -- sanitising the path therefore reserved characters which have a+ -- meaning in URI does not appear. Special casing for `/`, because it has+ -- a special meaning in FilePath as well as in URI.+ sanitize = escapeURIString (\c -> c == '/' || isUnreserved c)+++--------------------------------------------------------------------------------+-- | Get the relative url to the site root, for a given (absolute) url+toSiteRoot :: String -> String+toSiteRoot = removeWinPathSeparator . emptyException . joinPath+ . map parent . filter relevant . splitPath . takeDirectory+ where+ parent = const ".."+ emptyException [] = "."+ emptyException x = x+ relevant "." = False+ relevant "/" = False+ relevant "./" = False+ relevant _ = True+++--------------------------------------------------------------------------------+-- | Check if an URL links to an external HTTP(S) source+isExternal :: String -> Bool+isExternal url = any (flip isPrefixOf url) ["http://", "https://", "//"]+++--------------------------------------------------------------------------------+-- | Strip all HTML tags from a string+--+-- Example:+--+-- > stripTags "<p>foo</p>"+--+-- Result:+--+-- > "foo"+--+-- This also works for incomplete tags+--+-- Example:+--+-- > stripTags "<p>foo</p"+--+-- Result:+--+-- > "foo"+stripTags :: String -> String+stripTags [] = []+stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs+stripTags (x : xs) = x : stripTags xs+++--------------------------------------------------------------------------------+-- | HTML-escape a string+--+-- Example:+--+-- > escapeHtml "Me & Dean"+--+-- Result:+--+-- > "Me & Dean"+escapeHtml :: String -> String+escapeHtml = renderHtml . toHtml+++--------------------------------------------------------------------------------+data Srcset = Srcset {+ unSrcset :: [SrcsetImageCandidate]+ }+++--------------------------------------------------------------------------------+instance Show Srcset where+ show set = intercalate ", " $ map show $ unSrcset set+++--------------------------------------------------------------------------------+data SrcsetImageCandidate = SrcsetImageCandidate {+ srcsetImageCandidateUrl :: String+ , srcsetImageCandidateDescriptor :: Maybe String+ }+++--------------------------------------------------------------------------------+instance Show SrcsetImageCandidate where+ show candidate =+ let url = srcsetImageCandidateUrl candidate+ in case srcsetImageCandidateDescriptor candidate of+ Just desc -> concat [url, " ", desc]+ Nothing -> url+++--------------------------------------------------------------------------------+-- HTML spec: https://html.spec.whatwg.org/#srcset-attributes+srcsetParser :: P.Parsec String () Srcset+srcsetParser = do+ result <- candidate `P.sepBy1` (PC.char ',')+ P.eof+ return $ Srcset result+ where+ candidate :: P.Parsec String () SrcsetImageCandidate+ candidate = do+ P.skipMany ascii_whitespace+ u <- url+ P.skipMany ascii_whitespace+ desc <- P.optionMaybe $ P.choice $ fmap P.try [width_descriptor, px_density_descriptor]+ P.skipMany ascii_whitespace+ return $ SrcsetImageCandidate {+ srcsetImageCandidateUrl = u+ , srcsetImageCandidateDescriptor = desc+ }++ -- This is an over-simplification, but should be good enough for our purposes+ url :: P.Parsec String () String+ url = P.many1 $ PC.noneOf " ,"++ ascii_whitespace :: P.Parsec String () ()+ ascii_whitespace = void $ P.oneOf "\x09\x0A\x0C\x0D\x20"++ width_descriptor :: P.Parsec String () String+ width_descriptor = do+ number <- P.many1 PC.digit+ void $ PC.char 'w'+ return $ concat [number, "w"]++ px_density_descriptor :: P.Parsec String () String+ px_density_descriptor = do+ sign <- P.optionMaybe $ PC.char '-'+ int <- P.many1 PC.digit+ frac <- P.optionMaybe $ do+ void $ PC.char '.'+ frac <- P.many1 PC.digit+ return $ concat [".", frac]+ expon <- P.optionMaybe $ do+ letter <- P.oneOf "eE"+ e_sign <- P.optionMaybe $ PC.oneOf "-+"+ number <- P.many1 PC.digit+ return $ concat [[letter], mb $ fmap show e_sign, number]+ void $ PC.char 'x'+ return $ concat [mb $ fmap show sign, int, mb frac, mb expon, "x"]++ mb :: Maybe String -> String+ mb = fromMaybe ""
+ lib/Hakyll/Web/Html/RelativizeUrls.hs view
@@ -0,0 +1,52 @@+--------------------------------------------------------------------------------+-- | This module exposes a function which can relativize URL's on a webpage.+--+-- This means that one can deploy the resulting site on+-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@+-- without having to change anything (simply copy over the files).+--+-- To use it, you should use absolute URL's from the site root everywhere. For+-- example, use+--+-- > <img src="/images/lolcat.png" alt="Funny zomgroflcopter" />+--+-- in a blogpost. When running this through the relativize URL's module, this+-- will result in (suppose your blogpost is located at @\/posts\/foo.html@:+--+-- > <img src="../images/lolcat.png" alt="Funny zomgroflcopter" />+module Hakyll.Web.Html.RelativizeUrls+ ( relativizeUrls+ , relativizeUrlsWith+ ) where+++--------------------------------------------------------------------------------+import Data.List (isPrefixOf)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Html+++--------------------------------------------------------------------------------+-- | Compiler form of 'relativizeUrls' which automatically picks the right root+-- path+relativizeUrls :: Item String -> Compiler (Item String)+relativizeUrls item = do+ route <- getRoute $ itemIdentifier item+ return $ case route of+ Nothing -> item+ Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item+++--------------------------------------------------------------------------------+-- | Relativize URL's in HTML+relativizeUrlsWith :: String -- ^ Path to the site root+ -> String -- ^ HTML to relativize+ -> String -- ^ Resulting HTML+relativizeUrlsWith root = withUrls rel+ where+ isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)+ rel x = if isRel x then root ++ x else x
+ lib/Hakyll/Web/Meta/JSONLD.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary+for articles. Google applications and other search engines use+these data to improve search results and links.++This implementation supports the following fields:+++-------------------+----------------------------------------------------++| @\@type@ | __Hardcoded__ value @\"Article"@. |++-------------------+----------------------------------------------------++| @headline@ | __Required__ taken from context field @title@. |++-------------------+----------------------------------------------------++| @datePublished@ | __Required__ date of publication, via 'dateField'. |++-------------------+----------------------------------------------------+++To use, add a 'jsonldField' to your template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'jsonldField' "jsonld" context+@++And update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(jsonld)$$jsonld("embed")$$endif$+\</head>+@++The @"embed"@ argument generates a @\<script …>@ tag to be directly+included in page HTML. To get the raw JSON string, use @"raw"@+instead.++-}+module Hakyll.Web.Meta.JSONLD+ ( jsonldField+ ) where++import Data.Aeson ((.=), pairs)+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++runContext :: Context String -> String -> Compiler String+runContext ctx k = do+ i <- makeItem "dummy"+ unContext ctx k [] i >>= \cf -> case cf of+ StringField s -> pure s+ _ -> fail $ "Error: '" <> k <> "' is not a StringField"++getContext :: Context String -> String -> Compiler String+getContext ctx k = compilerTry (runContext ctx k) >>= either f pure+ where+ f (CompilationNoResult _) = compilerResult . CompilerError . CompilationFailure . pure $+ "missing required field '" <> k <> "'"+ f err = compilerResult (CompilerError err)++-- This may come in handy later+_lookupContext :: Context String -> String -> Compiler (Maybe String)+_lookupContext ctx k = compilerTry (runContext ctx k) >>= either f (pure . Just)+ where+ f (CompilationNoResult _) = pure Nothing+ f err = compilerResult (CompilerError err)++-- | Render JSON-LD for an article.+-- Requires context with "title", and the item must be able to yield+-- a valid date via 'getItemUTC'+--+renderJSONLD :: Context String -> Compiler (Item String)+renderJSONLD ctx = do+ dateString <- getContext (dateField "" "%Y-%m-%dT%H:%M:%S") ""+ titleString <- getContext ctx "title"++ let+ obj = pairs $+ "@context" .= ("https://schema.org" :: String)+ <> "@type" .= ("Article" :: String)+ <> "headline" .= titleString+ <> "datePublished" .= dateString++ makeItem . LT.unpack . LT.decodeUtf8 . encodingToLazyByteString $ obj++jsonldField :: String -> Context String -> Context String+jsonldField k ctx = functionField k (\args _i -> go args)+ where+ -- The zero argument case cannot be a compiler error,+ -- otherwise @$if(k)$@ evaluates false.+ go [] = pure $ "<!-- Whoops! Try this instead: $if(" <> k <> ")$$" <> k <> "(\"embed\")$$endif$ -->"+ go ["raw"] = itemBody <$> renderJSONLD ctx+ go ["embed"] = do+ template <- jsonldTemplate+ i <- renderJSONLD ctx >>= applyTemplate template (bodyField "body")+ pure $ itemBody i+ go [_] = fail $ "invalid argument to jsonldField '" <> k <> "'. use \"raw\" or \"embed\""+ go _ = fail $ "too many arguments to jsonldField '" <> k <> "'"++jsonldTemplate :: Compiler Template+jsonldTemplate = do+ makeItem "<script type=\"application/ld+json\">$body$</script>"+ >>= compileTemplateItem
+ lib/Hakyll/Web/Meta/OpenGraph.hs view
@@ -0,0 +1,71 @@+{- |++Open Graph metadata, as described at <https://ogp.me/>. This+implementation supports the following properties:+++------------------+----------------------------------------------------++| @og:type@ | __Hardcoded__ value @"article"@ |++------------------+----------------------------------------------------++| @og:url@ | __Required__ concatenation of @root@ and @url@ |+| | context fields, both of which are required. |++------------------+----------------------------------------------------++| @og:title@ | __Required__ title of article, from @title@ field. |++------------------+----------------------------------------------------++| @og:description@ | __Optional__ brief description taken from context |+| | field @og-description@, if set. |++------------------+----------------------------------------------------++| @og:image@ | __Optional__ image URL taken from context |+| | field @og-image@, if set. |++------------------+----------------------------------------------------+++To use, add 'openGraphField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext = context <> 'openGraphField' "opengraph" context+@++and update the template:++@+\<head>+ \<title>$title$</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+\</head>+@++See also "Hakyll.Web.Meta.TwitterCard".++-}+module Hakyll.Web.Meta.OpenGraph+ ( openGraphField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++openGraphField :: String -> Context String -> Context String+openGraphField k ctx = functionField k $ \_args i -> do+ template <- openGraphTemplate+ itemBody <$> applyTemplate template ctx i++openGraphTemplate :: Compiler Template+openGraphTemplate = do+ makeItem openGraphTemplateString >>= compileTemplateItem++openGraphTemplateString :: String+openGraphTemplateString =+ "<meta property=\"og:type\" content=\"article\" />\+ \<meta property=\"og:url\" content=\"$root$$url$\" />\+ \<meta property=\"og:title\" content=\"$title$\" />\+ \$if(og-description)$\+ \<meta property=\"og:description\" content=\"$og-description$\" />\+ \$endif$\+ \$if(og-image)$\+ \<meta property=\"og:image\" content=\"$og-image$\" />\+ \$endif$\+ \"
+ lib/Hakyll/Web/Meta/TwitterCard.hs view
@@ -0,0 +1,63 @@+{- |++Twitter Card metadata, as described at+<https://developer.twitter.com/en/docs/twitter-for-websites/cards/guides/getting-started>.+This feature should be used alongside "Hakyll.Web.Meta.OpenGraph".+The following properties are supported:+++-------------------+----------------------------------------------------++| @twitter:card@ | __Hardcoded__ card type = @"summary"@. |++-------------------+----------------------------------------------------++| @twitter:creator@ | __Optional__ author's Twitter user name. |+| | Taken from @twitter-creator@ context field, if set.|++-------------------+----------------------------------------------------++| @twitter:site@ | __Optional__ publication's Twitter user name. |+| | Taken from @twitter-site@ context field, if set. |++-------------------+----------------------------------------------------+++To use, add 'openGraphField' and 'twitterCardField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'openGraphField' "opengraph" context+ <> 'twitterCardField' "twitter" context+@++and update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+ $if(twitter)$$twitter$$endif$+\</head>+@++-}+module Hakyll.Web.Meta.TwitterCard+ ( twitterCardField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++twitterCardField :: String -> Context String -> Context String+twitterCardField k ctx = functionField k $ \_args i -> do+ template <- twitterCardTemplate+ itemBody <$> applyTemplate template ctx i++twitterCardTemplate :: Compiler Template+twitterCardTemplate = do+ makeItem twitterCardTemplateString >>= compileTemplateItem++twitterCardTemplateString :: String+twitterCardTemplateString =+ "<meta name=\"twitter:card\" content=\"summary\" />\+ \$if(twitter-creator)$<meta name=\"twitter:creator\" content=\"$twitter-creator$\" />$endif$\+ \$if(twitter-site)$<meta name=\"twitter:site\" content=\"$twitter-site$\" />$endif$"
+ lib/Hakyll/Web/Paginate.hs view
@@ -0,0 +1,154 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Paginate+ ( PageNumber+ , Paginate (..)+ , buildPaginateWith+ , paginateEvery+ , paginateRules+ , paginateContext+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative (empty)+import Control.Monad (forM_, forM)+import qualified Data.Map as M+import qualified Data.Set as S+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Core.Rules+import Hakyll.Web.Html+import Hakyll.Web.Template.Context+++--------------------------------------------------------------------------------+type PageNumber = Int+++--------------------------------------------------------------------------------+-- | Data about paginators+data Paginate = Paginate+ { paginateMap :: M.Map PageNumber [Identifier]+ , paginateMakeId :: PageNumber -> Identifier+ , paginateDependency :: Dependency+ }+++--------------------------------------------------------------------------------+paginateNumPages :: Paginate -> Int+paginateNumPages = M.size . paginateMap+++--------------------------------------------------------------------------------+paginateEvery :: Int -> [a] -> [[a]]+paginateEvery n = go+ where+ go [] = []+ go xs = let (y, ys) = splitAt n xs in y : go ys+++--------------------------------------------------------------------------------+buildPaginateWith+ :: MonadMetadata m+ => ([Identifier] -> m [[Identifier]]) -- ^ Group items into pages+ -> Pattern -- ^ Select items to paginate+ -> (PageNumber -> Identifier) -- ^ Identifiers for the pages+ -> m Paginate+buildPaginateWith grouper pattern makeId = do+ ids <- getMatches pattern+ idGroups <- grouper ids+ let idsSet = S.fromList ids+ return Paginate+ { paginateMap = M.fromList (zip [1 ..] idGroups)+ , paginateMakeId = makeId+ , paginateDependency = contentDependency $ PatternDependency pattern idsSet+ }+++--------------------------------------------------------------------------------+paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()+paginateRules paginator rules =+ forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) ->+ rulesExtraDependencies [paginateDependency paginator] $+ create [paginateMakeId paginator idx] $+ rules idx $ fromList identifiers+++--------------------------------------------------------------------------------+-- | Get the identifier for a certain page by passing in the page number.+paginatePage :: Paginate -> PageNumber -> Maybe Identifier+paginatePage pag pageNumber+ | pageNumber < 1 = Nothing+ | pageNumber > (paginateNumPages pag) = Nothing+ | otherwise = Just $ paginateMakeId pag pageNumber+++--------------------------------------------------------------------------------+-- | A default paginate context which provides the following keys:+--+--+-- * @firstPageNum@+-- * @firstPageUrl@+-- * @previousPageNum@+-- * @previousPageUrl@+-- * @nextPageNum@+-- * @nextPageUrl@+-- * @lastPageNum@+-- * @lastPageUrl@+-- * @currentPageNum@+-- * @currentPageUrl@+-- * @numPages@+-- * @allPages@+paginateContext :: Paginate -> PageNumber -> Context a+paginateContext pag currentPage = mconcat+ [ field "firstPageNum" $ \_ -> otherPage 1 >>= num+ , field "firstPageUrl" $ \_ -> otherPage 1 >>= url+ , field "previousPageNum" $ \_ -> otherPage (currentPage - 1) >>= num+ , field "previousPageUrl" $ \_ -> otherPage (currentPage - 1) >>= url+ , field "nextPageNum" $ \_ -> otherPage (currentPage + 1) >>= num+ , field "nextPageUrl" $ \_ -> otherPage (currentPage + 1) >>= url+ , field "lastPageNum" $ \_ -> otherPage lastPage >>= num+ , field "lastPageUrl" $ \_ -> otherPage lastPage >>= url+ , field "currentPageNum" $ \i -> thisPage i >>= num+ , field "currentPageUrl" $ \i -> thisPage i >>= url+ , constField "numPages" $ show $ paginateNumPages pag+ , Context $ \k _ i -> case k of+ "allPages" -> do+ let ctx =+ field "isCurrent" (\n -> if fst (itemBody n) == currentPage then return "true" else empty) `mappend`+ field "num" (num . itemBody) `mappend`+ field "url" (url . itemBody)++ list <- forM [1 .. lastPage] $+ \n -> if n == currentPage then thisPage i else otherPage n+ items <- mapM makeItem list+ return $ ListField ctx items+ _ -> do+ empty++ ]+ where+ lastPage = paginateNumPages pag++ thisPage i = return (currentPage, itemIdentifier i)+ otherPage n+ | n == currentPage = fail $ "This is the current page: " ++ show n+ | otherwise = case paginatePage pag n of+ Nothing -> fail $ "No such page: " ++ show n+ Just i -> return (n, i)++ num :: (Int, Identifier) -> Compiler String+ num = return . show . fst++ url :: (Int, Identifier) -> Compiler String+ url (n, i) = getRoute i >>= \mbR -> case mbR of+ Just r -> return $ toUrl r+ Nothing -> fail $ "No URL for page: " ++ show n
+ lib/Hakyll/Web/Pandoc.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+-- | Module exporting convenient pandoc bindings+module Hakyll.Web.Pandoc+ ( -- * The basic building blocks+ readPandoc+ , readPandocWith+ , writePandoc+ , writePandocWith+ , renderPandoc+ , renderPandocWith+ , renderPandocWithTransform+ , renderPandocWithTransformM+ , renderPandocItemWithTransformM++ -- * Derived compilers+ , pandocCompiler+ , pandocCompilerWith+ , pandocCompilerWithTransform+ , pandocCompilerWithTransformM+ , pandocItemCompilerWithTransformM++ -- * Default options+ , defaultHakyllReaderOptions+ , defaultHakyllWriterOptions+ ) where+++--------------------------------------------------------------------------------+import qualified Data.Text as T+import Text.Pandoc+import Text.Pandoc.Highlighting (pygments)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Pandoc.FileType+++--------------------------------------------------------------------------------+-- | Read a string using pandoc, with the default options+readPandoc+ :: Item String -- ^ String to read+ -> Compiler (Item Pandoc) -- ^ Resulting document+readPandoc = readPandocWith defaultHakyllReaderOptions+++--------------------------------------------------------------------------------+-- | Read a string using pandoc, with the supplied options+readPandocWith+ :: ReaderOptions -- ^ Parser options+ -> Item String -- ^ String to read+ -> Compiler (Item Pandoc) -- ^ Resulting document+readPandocWith ropt item =+ case runPure $ traverse (reader ropt (itemFileType item)) (fmap T.pack item) of+ Left err -> fail $+ "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ show err+ Right item' -> return item'+ where+ reader ro t = case t of+ DocBook -> readDocBook ro+ Html -> readHtml ro+ Jupyter -> readIpynb ro+ LaTeX -> readLaTeX ro+ LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'+ Markdown -> readMarkdown ro+ MediaWiki -> readMediaWiki ro+ OrgMode -> readOrg ro+ Rst -> readRST ro+#if MIN_VERSION_pandoc(3,8,3)+ AsciiDoc -> readAsciiDoc ro+#endif+#if MIN_VERSION_pandoc(3,1,12)+ Djot -> readDjot ro+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ Typst -> readTypst ro+#endif+ Textile -> readTextile ro+ _ -> error $+ "Hakyll.Web.readPandocWith: I don't know how to read a file of " +++ "the type " ++ show t ++ " for: " ++ show (itemIdentifier item)++ addExt ro e = ro {readerExtensions = enableExtension e $ readerExtensions ro}+++--------------------------------------------------------------------------------+-- | Write a document (as HTML) using pandoc, with the default options+writePandoc :: Item Pandoc -- ^ Document to write+ -> Item String -- ^ Resulting HTML+writePandoc = writePandocWith defaultHakyllWriterOptions+++--------------------------------------------------------------------------------+-- | Write a document (as HTML) using pandoc, with the supplied options+writePandocWith :: WriterOptions -- ^ Writer options for pandoc+ -> Item Pandoc -- ^ Document to write+ -> Item String -- ^ Resulting HTML+writePandocWith wopt (Item itemi doc) =+ case runPure $ writeHtml5String wopt doc of+ Left err -> error $ "Hakyll.Web.Pandoc.writePandocWith: " ++ show err+ Right item' -> Item itemi $ T.unpack item'+++--------------------------------------------------------------------------------+-- | Render the resource using pandoc+renderPandoc :: Item String -> Compiler (Item String)+renderPandoc =+ renderPandocWith defaultHakyllReaderOptions defaultHakyllWriterOptions+++--------------------------------------------------------------------------------+-- | Render the resource using pandoc+renderPandocWith+ :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String)+renderPandocWith ropt wopt item =+ writePandocWith wopt <$> readPandocWith ropt item+++--------------------------------------------------------------------------------+-- | An extension of `renderPandocWith`, which allows you to specify a custom+-- Pandoc transformation on the input `Item`.+-- Useful if you want to do your own transformations before running+-- custom Pandoc transformations, e.g. using a `funcField` to transform raw content.+renderPandocWithTransform :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransform ropt wopt f =+ renderPandocWithTransformM ropt wopt (return . f)+++--------------------------------------------------------------------------------+-- | Similar to 'renderPandocWithTransform', but the Pandoc transformation is+-- monadic. This is useful when you want the pandoc+-- transformation to use the 'Compiler' information such as routes,+-- metadata, etc. along with your own transformations beforehand.+--+-- @since 4.16.3.0+renderPandocWithTransformM :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Compiler Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (traverse f =<< readPandocWith ropt i)+++--------------------------------------------------------------------------------+-- | Like 'renderPandocWithTransformM', but work on an @'Item' 'Pandoc'@ instead+-- of just a 'Pandoc'. This allows for more seamless composition of functions+-- that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+--+-- @since 4.16.3.0+renderPandocItemWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Item String+ -> Compiler (Item String)+renderPandocItemWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (f =<< readPandocWith ropt i)+++--------------------------------------------------------------------------------+-- | Read a page render using pandoc+pandocCompiler :: Compiler (Item String)+pandocCompiler =+ pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions+++--------------------------------------------------------------------------------+-- | A version of 'pandocCompiler' which allows you to specify your own pandoc+-- options+pandocCompilerWith :: ReaderOptions -> WriterOptions -> Compiler (Item String)+pandocCompilerWith ropt wopt =+ cached "Hakyll.Web.Pandoc.pandocCompilerWith" $+ pandocCompilerWithTransform ropt wopt id+++--------------------------------------------------------------------------------+-- | An extension of 'pandocCompilerWith' which allows you to specify a custom+-- pandoc transformation for the content+pandocCompilerWithTransform :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Pandoc)+ -> Compiler (Item String)+pandocCompilerWithTransform ropt wopt f =+ pandocCompilerWithTransformM ropt wopt (return . f)+++--------------------------------------------------------------------------------+-- | Similar to 'pandocCompilerWithTransform', but the transformation+-- function is monadic. This is useful when you want the pandoc+-- transformation to use the 'Compiler' information such as routes,+-- metadata, etc+pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Compiler Pandoc)+ -> Compiler (Item String)+pandocCompilerWithTransformM ropt wopt f =+ getResourceBody >>= renderPandocWithTransformM ropt wopt f+++--------------------------------------------------------------------------------+-- | Like 'pandocCompilerWithTransformM', but work on an 'Item' 'Pandoc'+-- instead of just a 'Pandoc'. This allows for more seamless composition of+-- functions that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+pandocItemCompilerWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Compiler (Item String)+pandocItemCompilerWithTransformM ropt wopt f =+ getResourceBody >>= renderPandocItemWithTransformM ropt wopt f+++--------------------------------------------------------------------------------+-- | The default reader options for pandoc parsing in hakyll+defaultHakyllReaderOptions :: ReaderOptions+defaultHakyllReaderOptions = def+ { -- The following option causes pandoc to read smart typography, a nice+ -- and free bonus.+ readerExtensions = enableExtension Ext_smart pandocExtensions+ }+++--------------------------------------------------------------------------------+-- | The default writer options for pandoc rendering in hakyll+defaultHakyllWriterOptions :: WriterOptions+defaultHakyllWriterOptions = def+ { -- This option causes literate haskell to be written using '>' marks in+ -- html, which I think is a good default.+ writerExtensions = enableExtension Ext_smart pandocExtensions+ , -- We want to have hightlighting by default, to be compatible with earlier+ -- Hakyll releases+#if MIN_VERSION_pandoc(3,8,0)+ -- Starting with pandoc 3.8, the highlighting+ -- system was overhauled to have more than just Skylighting+ -- styles+ writerHighlightMethod = Skylighting pygments+#else+ writerHighlightStyle = Just pygments+#endif+ , -- Do not word-wrap produced HTML, and do not undo any word-wrapping+ -- that's already present in the markup. This is how Pandoc operated+ -- prior to 2.17, but the behaviour was changed for consistency with+ -- other Pandoc writers. We retain the old behaviour because it spares us+ -- the trouble of updating our golden tests.+ writerWrapText = WrapPreserve+ }
+ lib/Hakyll/Web/Pandoc/Biblio.hs view
@@ -0,0 +1,240 @@+--------------------------------------------------------------------------------+-- | Wraps pandocs bibiliography handling+--+-- In order to add a bibliography, you will need a bibliography file (e.g.+-- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their+-- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can+-- refer to these files when you use 'readPandocBiblio'. This function also+-- takes the reader options for completeness -- you can use+-- 'defaultHakyllReaderOptions' if you're unsure. If you already read the+-- source into a 'Pandoc' type and need to add processing for the bibliography,+-- you can use 'processPandocBiblio' instead.+-- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',+-- but also takes paths to compiled bibliography and csl files;+-- 'pandocBibliosCompiler' is similar but instead takes a glob pattern for bib files.+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Pandoc.Biblio+ ( CSL (..)+ , cslCompiler+ , Biblio (..)+ , biblioCompiler+ , readPandocBiblio+ , readPandocBiblios+ , processPandocBiblio+ , processPandocBiblios+ , pandocBiblioCompiler+ , pandocBibliosCompiler+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (liftM)+import Data.Binary (Binary (..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as Map+import qualified Data.Time as Time+import qualified Data.Text as T (pack)+import Data.Typeable (Typeable)+import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern (fromGlob)+import Hakyll.Core.Item+import Hakyll.Core.Metadata (getMetadataField)+import Hakyll.Core.Writable+import Hakyll.Web.Pandoc+import Text.Pandoc (Extension (..), Pandoc,+ PandocPure, ReaderOptions (..),+ enableExtension)+import qualified Text.Pandoc as Pandoc+import Text.Pandoc.Builder (setMeta)+import qualified Text.Pandoc.Citeproc as Pandoc (processCitations)+import Text.Pandoc.Walk (Walkable (query))+import System.FilePath (addExtension, takeExtension)+++--------------------------------------------------------------------------------+newtype CSL = CSL {unCSL :: B.ByteString}+ deriving (Binary, Show, Typeable)++++--------------------------------------------------------------------------------+instance Writable CSL where+ -- Shouldn't be written.+ write _ _ = return ()+++--------------------------------------------------------------------------------+cslCompiler :: Compiler (Item CSL)+cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS+++--------------------------------------------------------------------------------+newtype Biblio = Biblio {unBiblio :: B.ByteString}+ deriving (Binary, Show, Typeable)+++--------------------------------------------------------------------------------+instance Writable Biblio where+ -- Shouldn't be written.+ write _ _ = return ()+++--------------------------------------------------------------------------------+biblioCompiler :: Compiler (Item Biblio)+biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS+++--------------------------------------------------------------------------------+readPandocBiblio :: ReaderOptions+ -> Item CSL+ -> Item Biblio+ -> (Item String)+ -> Compiler (Item Pandoc)+readPandocBiblio ropt csl biblio = readPandocBiblios ropt csl [biblio]++readPandocBiblios :: ReaderOptions+ -> Item CSL+ -> [Item Biblio]+ -> (Item String)+ -> Compiler (Item Pandoc)+readPandocBiblios ropt csl biblios item = do+ pandoc <- readPandocWith ropt item+ processPandocBiblios csl biblios pandoc+++--------------------------------------------------------------------------------++-- | Process a bibliography file with the given style.+--+-- This function supports pandoc's+-- <https://pandoc.org/chunkedhtml-demo/9.6-including-uncited-items-in-the-bibliography.html nocite>+-- functionality when there is a @nocite@ metadata field present.+--+-- ==== __Example__+--+-- In your main function, first compile the respective files:+--+-- > main = hakyll $ do+-- > …+-- > match "style.csl" $ compile cslCompiler+-- > match "bib.bib" $ compile biblioCompiler+--+-- Then, create a function like the following:+--+-- > processBib :: Item Pandoc -> Compiler (Item Pandoc)+-- > processBib pandoc = do+-- > csl <- load @CSL "bib/style.csl"+-- > bib <- load @Biblio "bib/bibliography.bib"+-- > processPandocBiblio csl bib pandoc+--+-- Now, feed this function to your pandoc compiler:+--+-- > myCompiler :: Compiler (Item String)+-- > myCompiler = pandocItemCompilerWithTransformM myReader myWriter processBib+processPandocBiblio :: Item CSL+ -> Item Biblio+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblio csl biblio = processPandocBiblios csl [biblio]++-- | Like 'processPandocBiblio', which see, but support multiple bibliography+-- files.+processPandocBiblios :: Item CSL+ -> [Item Biblio]+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblios csl biblios item' = do+ -- It's not straightforward to use the Pandoc API as of 2.11 to deal with+ -- citations, since it doesn't export many things in 'Text.Pandoc.Citeproc'.+ -- The 'citeproc' package is also hard to use.+ --+ -- So instead, we try treating Pandoc as a black box. Pandoc can read+ -- specific csl and bilbio files based on metadata keys.+ --+ -- So we load the CSL and Biblio files and pass them to Pandoc using the+ -- ersatz filesystem.++ -- Honour nocite metadata fields+ item <- getUnderlying >>= (`getMetadataField` "nocite") >>= \case+ Nothing -> pure item'+ Just x -> withItemBody (pure . setMeta "nocite" x) item'++ let Pandoc.Pandoc (Pandoc.Meta meta) blocks = itemBody item+ cslFile = Pandoc.FileInfo zeroTime . unCSL $ itemBody csl+ bibFiles = zipWith (\x y ->+ ( addExtension ("_hakyll/bibliography-" ++ show x)+ (takeExtension $ toFilePath $ itemIdentifier y)+ , Pandoc.FileInfo zeroTime . unBiblio . itemBody $ y+ )+ )+ [0 :: Integer ..]+ biblios++ stFiles = foldr ((.) . uncurry Pandoc.insertInFileTree)+ (Pandoc.insertInFileTree "_hakyll/style.csl" cslFile)+ bibFiles++ addBiblioFiles = \st -> st { Pandoc.stFiles = stFiles $ Pandoc.stFiles st }++ biblioMeta = Pandoc.Meta .+ Map.insert "csl" (Pandoc.MetaString "_hakyll/style.csl") .+ Map.insert "bibliography"+ (Pandoc.MetaList $ map (Pandoc.MetaString . T.pack . fst) bibFiles) $+ meta++ pandoc <- do+ let p = Pandoc.Pandoc biblioMeta blocks+ p' <- case Pandoc.lookupMeta "nocite" biblioMeta of+ Just (Pandoc.MetaString nocite) -> do+ Pandoc.Pandoc _ b <- runPandoc $+ Pandoc.readMarkdown defaultHakyllReaderOptions nocite+ let nocites = Pandoc.MetaInlines . flip query b $ \case+ c@Pandoc.Cite{} -> [c]+ _ -> []+ return $ setMeta "nocite" nocites p+ _ -> return p+ runPandoc $ do+ Pandoc.modifyPureState addBiblioFiles+ Pandoc.processCitations p'+ return $ fmap (const pandoc) item++ where+ zeroTime = Time.UTCTime (toEnum 0) 0++ runPandoc :: PandocPure a -> Compiler a+ runPandoc with = case Pandoc.runPure with of+ Left e -> compilerThrow ["Error during processCitations: " ++ show e]+ Right x -> pure x++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.+pandocBiblioCompiler :: String -> String -> Compiler (Item String)+pandocBiblioCompiler cslFileName bibFileName = do+ csl <- load $ fromFilePath cslFileName+ bib <- load $ fromFilePath bibFileName+ liftM writePandoc+ (getResourceBody >>= readPandocBiblio ropt csl bib)+ where ropt = defaultHakyllReaderOptions+ { -- The following option enables citation rendering+ readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions+ }++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.+pandocBibliosCompiler :: String -> String -> Compiler (Item String)+pandocBibliosCompiler cslFileName bibFileName = do+ csl <- load $ fromFilePath cslFileName+ bibs <- loadAll $ fromGlob bibFileName+ liftM writePandoc+ (getResourceBody >>= readPandocBiblios ropt csl bibs)+ where ropt = defaultHakyllReaderOptions+ { -- The following option enables citation rendering+ readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions+ }
+ lib/Hakyll/Web/Pandoc/Binary.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+module Hakyll.Web.Pandoc.Binary where++import Data.Binary (Binary (..))++import Text.Pandoc++--------------------------------------------------------------------------------+-- orphans++instance Binary Alignment+instance Binary Block+instance Binary Caption+instance Binary Cell+instance Binary ColSpan+instance Binary ColWidth+instance Binary Citation+instance Binary CitationMode+instance Binary Format+instance Binary Inline+instance Binary ListNumberDelim+instance Binary ListNumberStyle+instance Binary MathType+instance Binary QuoteType+instance Binary Row+instance Binary RowHeadColumns+instance Binary RowSpan+instance Binary TableBody+instance Binary TableFoot+instance Binary TableHead
+ lib/Hakyll/Web/Pandoc/FileType.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+-- | A module dealing with pandoc file extensions and associated file types+module Hakyll.Web.Pandoc.FileType+ ( FileType (..)+ , fileType+ , itemFileType+ ) where+++--------------------------------------------------------------------------------+import System.FilePath (splitExtension)+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Item+++--------------------------------------------------------------------------------+-- | Datatype to represent the different file types Hakyll can deal with by+-- default+data FileType+ = Binary+ | Css+ | DocBook+ | Html+ | Jupyter+ | LaTeX+ | LiterateHaskell FileType+ | Markdown+ | MediaWiki+ | OrgMode+ | PlainText+ | Rst+ | Textile+#if MIN_VERSION_pandoc(3,8,3)+ | AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ | Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ | Typst+#endif+ deriving (Eq, Ord, Show, Read)+++--------------------------------------------------------------------------------+-- | Get the file type for a certain file. The type is determined by extension.+fileType :: FilePath -> FileType+fileType = uncurry fileType' . splitExtension+ where+ fileType' _ ".css" = Css+ fileType' _ ".dbk" = DocBook+ fileType' _ ".ipynb" = Jupyter+ fileType' _ ".htm" = Html+ fileType' _ ".html" = Html+ fileType' f ".lhs" = LiterateHaskell $ case fileType f of+ -- If no extension is given, default to Markdown + LiterateHaskell+ Binary -> Markdown+ -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified+ x -> x+ fileType' _ ".markdown" = Markdown+ fileType' _ ".mediawiki" = MediaWiki+ fileType' _ ".md" = Markdown+ fileType' _ ".mdn" = Markdown+ fileType' _ ".mdown" = Markdown+ fileType' _ ".mdwn" = Markdown+ fileType' _ ".mkd" = Markdown+ fileType' _ ".mkdwn" = Markdown+ fileType' _ ".org" = OrgMode+ fileType' _ ".page" = Markdown+ fileType' _ ".rst" = Rst+ fileType' _ ".tex" = LaTeX+ fileType' _ ".text" = PlainText+ fileType' _ ".textile" = Textile+ fileType' _ ".txt" = PlainText+#if MIN_VERSION_pandoc(3,8,3)+ fileType' _ ".asciidoc" = AsciiDoc+ fileType' _ ".adoc" = AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ fileType' _ ".dj" = Djot+ fileType' _ ".djot" = Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ fileType' _ ".typ" = Typst+#endif+ fileType' _ ".wiki" = MediaWiki+ fileType' _ _ = Binary -- Treat unknown files as binary+++--------------------------------------------------------------------------------+-- | Get the file type for the current file+itemFileType :: Item a -> FileType+itemFileType = fileType . toFilePath . itemIdentifier
+ lib/Hakyll/Web/Redirect.hs view
@@ -0,0 +1,99 @@+-- | Module used for generating HTML redirect pages. This allows renaming pages+-- to avoid breaking existing links without requiring server-side support for+-- formal 301 Redirect error codes+module Hakyll.Web.Redirect+ ( Redirect (..)+ , createRedirects+ ) where++import Control.Monad (forM_, when)+import Data.Binary (Binary (..))+import Data.List (sort, group)+import Hakyll.Core.Compiler+import Hakyll.Core.Identifier+import Hakyll.Core.Routes+import Hakyll.Core.Rules+import Hakyll.Core.Writable (Writable (..))++-- | This function exposes a higher-level interface compared to using the+-- 'Redirect' type manually.+--+-- This creates, using a database mapping broken URLs to working ones, HTML+-- files which will do HTML META tag redirect pages (since, as a static site, we+-- can't use web-server-level 301 redirects, and using JS is gross).+--+-- This is useful for sending people using old URLs to renamed versions, dealing+-- with common typos etc, and will increase site traffic. Such broken URLs can+-- be found by looking at server logs or by using Google Webmaster Tools.+-- Broken URLs must be valid Haskell strings, non-URL-escaped valid POSIX+-- filenames, and relative links, since they will be defined in a @hakyll.hs@+-- and during generation, written to disk with the filename corresponding to the+-- broken URLs. (Target URLs can be absolute or relative, but should be+-- URL-escaped.) So broken incoming links like <http://www.gwern.net/foo/> which+-- should be <http://www.gwern.net/foobar> cannot be fixed (since you cannot+-- create a HTML file named @"foo/"@ on disk, as that would be a directory).+--+-- An example of a valid association list would be:+--+-- > brokenLinks =+-- > [ ("projects.html", "http://github.com/gwern")+-- > , ("/Black-market archive", "Black-market%20archives")+-- > ]+--+-- In which case the functionality can then be used in `main` with a line like:+--+-- > version "redirects" $ createRedirects brokenLinks+--+-- The 'version' is recommended to separate these items from your other pages.+--+-- The on-disk files can then be uploaded with HTML mimetypes+-- (either explicitly by generating and uploading them separately, by+-- auto-detection of the filetype, or an upload tool defaulting to HTML+-- mimetype, such as calling @s3cmd@ with @--default-mime-type=text/html@) and+-- will redirect browsers and search engines going to the old/broken URLs.+--+-- See also <https://groups.google.com/d/msg/hakyll/sWc6zxfh-uM/fUpZPsFNDgAJ>.+createRedirects :: [(Identifier, String)] -> Rules ()+createRedirects redirects =+ do -- redirects are many-to-fewer; keys must be unique, and must point somewhere else:+ let gkeys = group $ sort $ map fst redirects+ forM_ gkeys $ \gkey -> case gkey of+ (k : _ : _) -> fail $+ "Duplicate 301 redirects; " ++ show k ++ " is ambiguous."+ _ -> return ()++ forM_ redirects $ \(r, t) ->+ when (toFilePath r == t) $ fail $+ "Self-redirect detected: " ++ show r ++ " points to itself."++ forM_ redirects $ \(ident, to) ->+ create [ident] $ do+ route idRoute+ compile $ makeItem $! Redirect to++-- | This datatype can be used directly if you want a lower-level interface to+-- generate redirects. For example, if you want to redirect @foo.html@ to+-- @bar.jpg@, you can use:+--+-- > create ["foo.html"] $ do+-- > route idRoute+-- > compile $ makeItem $ Redirect "bar.jpg"+data Redirect = Redirect+ { redirectTo :: String+ } deriving (Eq, Ord, Show)++instance Binary Redirect where+ put (Redirect to) = put to+ get = Redirect <$> get++instance Writable Redirect where+ write path = write path . fmap redirectToHtml++redirectToHtml :: Redirect -> String+redirectToHtml (Redirect working) =+ "<!DOCTYPE html><html><head><meta charset=\"utf-8\"/><meta name=\"generator\" content=\"hakyll\"/>" +++ "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">" +++ "<meta http-equiv=\"refresh\" content=\"0; url=" ++ working +++ "\"><link rel=\"canonical\" href=\"" ++ working +++ "\"><title>Permanent Redirect</title></head><body><p>The page has moved to: <a href=\"" ++ working +++ "\">this page</a></p></body></html>"
+ lib/Hakyll/Web/Tags.hs view
@@ -0,0 +1,356 @@+--------------------------------------------------------------------------------+-- | This module containing some specialized functions to deal with tags. It+-- assumes you follow some conventions.+--+-- We support two types of tags: tags and categories.+--+-- To use default tags, use 'buildTags'. Tags are placed in a comma-separated+-- metadata field like this:+--+-- > ---+-- > author: Philip K. Dick+-- > title: Do androids dream of electric sheep?+-- > tags: future, science fiction, humanoid+-- > ---+-- > The novel is set in a post-apocalyptic near future, where the Earth and+-- > its populations have been damaged greatly by Nuclear...+--+-- To use categories, use the 'buildCategories' function. Categories are+-- determined by the directory a page is in, for example, the post+--+-- > posts/coding/2010-01-28-hakyll-categories.markdown+--+-- will receive the @coding@ category.+--+-- Advanced users may implement custom systems using 'buildTagsWith' if desired.+--+-- In the above example, we would want to create a page which lists all pages in+-- the @coding@ category, for example, with the 'Identifier':+--+-- > tags/coding.html+--+-- This is where the first parameter of 'buildTags' and 'buildCategories' comes+-- in. In the above case, we used the function:+--+-- > fromCapture "tags/*.html" :: String -> Identifier+--+-- The 'tagsRules' function lets you generate such a page for each tag in the+-- 'Rules' monad.+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Tags+ ( Tags (..)+ , getTags+ , getTagsByField+ , getCategory+ , buildTagsWith+ , buildTags+ , buildCategories+ , tagsRules+ , renderTags+ , renderTagCloud+ , renderTagCloudWith+ , tagCloudField+ , tagCloudFieldWith+ , renderTagList+ , tagsField+ , tagsFieldWith+ , categoryField+ , simpleRenderLink+ , sortTagsBy+ , caseInsensitiveTags+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow ((&&&))+import Control.Monad (foldM, forM, forM_, mplus)+import Data.Char (toLower)+import Data.List (intercalate, intersperse,+ sortBy)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe)+import Data.Ord (comparing)+import qualified Data.Set as S+import System.FilePath (takeBaseName, takeDirectory)+import Text.Blaze.Html (toHtml, toValue, (!))+import Text.Blaze.Html.Renderer.String (renderHtml)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Dependencies+import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Core.Rules+import Hakyll.Core.Util.String+import Hakyll.Web.Html+import Hakyll.Web.Template.Context+++--------------------------------------------------------------------------------+-- | Data about tags+data Tags = Tags+ { tagsMap :: [(String, [Identifier])]+ , tagsMakeId :: String -> Identifier+ , tagsDependency :: Dependency+ }+++--------------------------------------------------------------------------------+-- | Obtain tags from a page in the default way: parse them from the @tags@+-- metadata field. This can either be a list or a comma-separated string.+getTags :: MonadMetadata m => Identifier -> m [String]+getTags = getTagsByField "tags"++-- | Obtain tags from a page by name of the metadata field. These can be a list+-- or a comma-separated string+getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]+getTagsByField fieldName identifier = do+ metadata <- getMetadata identifier+ return $ fromMaybe [] $+ (lookupStringList fieldName metadata) `mplus`+ (map trim . splitAll "," <$> lookupString fieldName metadata)+++--------------------------------------------------------------------------------+-- | Obtain category from a page.+getCategory :: MonadMetadata m => Identifier -> m [String]+getCategory = return . return . takeBaseName . takeDirectory . toFilePath+++--------------------------------------------------------------------------------+-- | Higher-order function to read tags+buildTagsWith :: MonadMetadata m+ => (Identifier -> m [String])+ -> Pattern+ -> (String -> Identifier)+ -> m Tags+buildTagsWith f pattern makeId = do+ ids <- getMatches pattern+ tagMap <- foldM addTags M.empty ids+ let set' = S.fromList ids+ return $ Tags (M.toList tagMap) makeId+ (metadataDependency $ PatternDependency pattern set')+ where+ -- Create a tag map for one page+ addTags tagMap id' = do+ tags <- f id'+ let tagMap' = M.fromList $ zip tags $ repeat [id']+ return $ M.unionWith (++) tagMap tagMap'+++--------------------------------------------------------------------------------+buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags+buildTags = buildTagsWith getTags+++--------------------------------------------------------------------------------+buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)+ -> m Tags+buildCategories = buildTagsWith getCategory+++--------------------------------------------------------------------------------+tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()+tagsRules tags rules =+ forM_ (tagsMap tags) $ \(tag, identifiers) ->+ rulesExtraDependencies [tagsDependency tags] $+ create [tagsMakeId tags tag] $+ rules tag $ fromList identifiers+++--------------------------------------------------------------------------------+-- | Render tags in HTML (the flexible higher-order function)+renderTags :: (String -> String -> Int -> Int -> Int -> String)+ -- ^ Produce a tag item: tag, url, count, min count, max count+ -> ([String] -> String)+ -- ^ Join items+ -> Tags+ -- ^ Tag cloud renderer+ -> Compiler String+renderTags makeHtml concatHtml tags = do+ -- In tags' we create a list: [((tag, route), count)]+ tags' <- forM (tagsMap tags) $ \(tag, ids) -> do+ route' <- getRoute $ tagsMakeId tags tag+ return ((tag, route'), length ids)++ -- TODO: We actually need to tell a dependency here!++ let -- Absolute frequencies of the pages+ freqs = map snd tags'++ -- The minimum and maximum count found+ (min', max')+ | null freqs = (0, 1)+ | otherwise = (minimum &&& maximum) freqs++ -- Create a link for one item+ makeHtml' ((tag, url), count) =+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'++ -- Render and return the HTML+ return $ concatHtml $ map makeHtml' tags'+++--------------------------------------------------------------------------------+-- | Render a tag cloud in HTML+renderTagCloud :: Double+ -- ^ Smallest font size, in percent+ -> Double+ -- ^ Biggest font size, in percent+ -> Tags+ -- ^ Input tags+ -> Compiler String+ -- ^ Rendered cloud+renderTagCloud = renderTagCloudWith makeLink (intercalate " ")+ where+ makeLink minSize maxSize tag url count min' max' =+ -- Show the relative size of one 'count' in percent+ let diff = 1 + fromIntegral max' - fromIntegral min'+ relative = (fromIntegral count - fromIntegral min') / diff+ size = floor $ minSize + relative * (maxSize - minSize) :: Int+ in renderHtml $+ H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%")+ ! A.href (toValue url)+ $ toHtml tag+++--------------------------------------------------------------------------------+-- | Render a tag cloud in HTML+renderTagCloudWith :: (Double -> Double ->+ String -> String -> Int -> Int -> Int -> String)+ -- ^ Render a single tag link+ -> ([String] -> String)+ -- ^ Concatenate links+ -> Double+ -- ^ Smallest font size, in percent+ -> Double+ -- ^ Biggest font size, in percent+ -> Tags+ -- ^ Input tags+ -> Compiler String+ -- ^ Rendered cloud+renderTagCloudWith makeLink cat minSize maxSize =+ renderTags (makeLink minSize maxSize) cat+++--------------------------------------------------------------------------------+-- | Render a tag cloud in HTML as a context+tagCloudField :: String+ -- ^ Destination key+ -> Double+ -- ^ Smallest font size, in percent+ -> Double+ -- ^ Biggest font size, in percent+ -> Tags+ -- ^ Input tags+ -> Context a+ -- ^ Context+tagCloudField key minSize maxSize tags =+ field key $ \_ -> renderTagCloud minSize maxSize tags+++--------------------------------------------------------------------------------+-- | Render a tag cloud in HTML as a context+tagCloudFieldWith :: String+ -- ^ Destination key+ -> (Double -> Double ->+ String -> String -> Int -> Int -> Int -> String)+ -- ^ Render a single tag link+ -> ([String] -> String)+ -- ^ Concatenate links+ -> Double+ -- ^ Smallest font size, in percent+ -> Double+ -- ^ Biggest font size, in percent+ -> Tags+ -- ^ Input tags+ -> Context a+ -- ^ Context+tagCloudFieldWith key makeLink cat minSize maxSize tags =+ field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags+++--------------------------------------------------------------------------------+-- | Render a simple tag list in HTML, with the tag count next to the item+-- TODO: Maybe produce a Context here+renderTagList :: Tags -> Compiler (String)+renderTagList = renderTags makeLink (intercalate ", ")+ where+ makeLink tag url count _ _ = renderHtml $+ H.a ! A.href (toValue url) ! A.rel "tag" $ toHtml (tag ++ " (" ++ show count ++ ")")+++--------------------------------------------------------------------------------+-- | Render tags with links with custom functions to get tags and to+-- render links+tagsFieldWith :: (Identifier -> Compiler [String])+ -- ^ Get the tags+ -> (String -> (Maybe FilePath) -> Maybe H.Html)+ -- ^ Render link for one tag+ -> ([H.Html] -> H.Html)+ -- ^ Concatenate tag links+ -> String+ -- ^ Destination field+ -> Tags+ -- ^ Tags structure+ -> Context a+ -- ^ Resulting context+tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do+ tags' <- getTags' $ itemIdentifier item+ links <- forM tags' $ \tag -> do+ route' <- getRoute $ tagsMakeId tags tag+ return $ renderLink tag route'++ return $ renderHtml $ cat $ catMaybes $ links+++--------------------------------------------------------------------------------+-- | Render tags with links+tagsField :: String -- ^ Destination key+ -> Tags -- ^ Tags+ -> Context a -- ^ Context+tagsField =+ tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ")+++--------------------------------------------------------------------------------+-- | Render the category in a link+categoryField :: String -- ^ Destination key+ -> Tags -- ^ Tags+ -> Context a -- ^ Context+categoryField =+ tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ")+++--------------------------------------------------------------------------------+-- | Render one tag link+simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html+simpleRenderLink _ Nothing = Nothing+simpleRenderLink tag (Just filePath) = Just $+ H.a ! A.title (H.stringValue ("All pages tagged '"++tag++"'."))+ ! A.href (toValue $ toUrl filePath)+ ! (A.rel "tag")+ $ toHtml tag+++--------------------------------------------------------------------------------+-- | Sort tags using supplied function. First element of the tuple passed to+-- the comparing function is the actual tag name.+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)+ -> Tags -> Tags+sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}+++--------------------------------------------------------------------------------+-- | Sample sorting function that compares tags case insensitively.+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])+ -> Ordering+caseInsensitiveTags = comparing $ map toLower . fst
+ lib/Hakyll/Web/Template.hs view
@@ -0,0 +1,178 @@+-- | This module provides means for reading and applying 'Template's.+--+-- Templates are tools to convert items into a string. They are perfectly suited+-- for laying out your site.+--+-- Let's look at an example template:+--+-- > <html>+-- > <head>+-- > <title>My crazy homepage - $title$</title>+-- > </head>+-- > <body>+-- > <div id="header">+-- > <h1>My crazy homepage - $title$</h1>+-- > </div>+-- > <div id="content">+-- > $body$+-- > </div>+-- > <div id="footer">+-- > By reading this you agree that I now own your soul+-- > </div>+-- > </body>+-- > </html>+--+-- As you can see, the format is very simple -- @$key$@ is used to render the+-- @$key$@ field from the page, everything else is literally copied. If you want+-- to literally insert @\"$key$\"@ into your page (for example, when you're+-- writing a Hakyll tutorial) you can use+--+-- > <p>+-- > A literal $$key$$.+-- > </p>+--+-- Because of it's simplicity, these templates can be used for more than HTML:+-- you could make, for example, CSS or JS templates as well.+--+-- Apart from interpolating @$key$@s from the 'Context' you can also+-- use the following macros:+--+-- * @$if(key)$@+--+-- > $if(key)$+-- > <b> Defined </b>+-- > $else$+-- > <b> Non-defined </b>+-- > $endif$+--+-- This example will print @Defined@ if @key@ is defined in the+-- context and @Non-defined@ otherwise. The @$else$@ clause is+-- optional.+--+-- * @$for(key)$@+--+-- The @for@ macro is used for enumerating 'Context' elements that are+-- lists, i.e. constructed using the 'listField' function. Assume that+-- in a context we have an element @listField \"key\" c itms@. Then+-- the snippet+--+-- > $for(key)$+-- > $x$+-- > $sep$,+-- > $endfor$+--+-- would, for each item @i@ in 'itms', lookup @$x$@ in the context @c@+-- with item @i@, interpolate it, and join the resulting list with+-- @,@.+--+-- Another concrete example one may consider is the following. Given the+-- context+--+-- > listField "things" (field "thing" (return . itemBody))+-- > (sequence [makeItem "fruits", makeItem "vegetables"])+--+-- and a template+--+-- > I like+-- > $for(things)$+-- > fresh $thing$$sep$, and+-- > $endfor$+--+-- the resulting page would look like+--+-- > <p>+-- > I like+-- >+-- > fresh fruits, and+-- >+-- > fresh vegetables+-- > </p>+--+-- The @$sep$@ part can be omitted. Usually, you can get by using the+-- 'applyListTemplate' and 'applyJoinListTemplate' functions.+--+-- * @$partial(path)$@+--+-- Loads a template located in a separate file and interpolates it+-- under the current context.+--+-- Assuming that the file @test.html@ contains+--+-- > <b>$key$</b>+--+-- The result of rendering+--+-- > <p>+-- > $partial("test.html")$+-- > </p>+--+-- is the same as the result of rendering+--+-- > <p>+-- > <b>$key$</b>+-- > </p>+--+-- That is, calling @$partial$@ is equivalent to just copying and pasting+-- template code.+--+-- In the examples above you can see that the outputs contain a lot of leftover+-- whitespace that you may wish to remove. Using @'$-'@ or @'-$'@ instead of+-- @'$'@ in a macro strips all whitespace to the left or right of that clause+-- respectively. Given the context+--+-- > listField "counts" (field "count" (return . itemBody))+-- > (sequence [makeItem "3", makeItem "2", makeItem "1"])+--+-- and a template+--+-- > <p>+-- > $for(counts)-$+-- > $count$+-- > $-sep$...+-- > $-endfor$+-- > </p>+--+-- the resulting page would look like+--+-- > <p>+-- > 3...2...1+-- > </p>+--+{-# LANGUAGE TemplateHaskell #-}+module Hakyll.Web.Template+ ( Template+ , templateBodyCompiler+ , templateCompiler+ , applyTemplate+ , loadAndApplyTemplate+ , applyAsTemplate+ , readTemplate+ , compileTemplateItem+ , unsafeReadTemplateFile+ , embedTemplate+ ) where+++--------------------------------------------------------------------------------+import Hakyll.Web.Template.Internal+++--------------------------------------------------------------------------------+import Data.FileEmbed (embedFile)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Language.Haskell.TH (Exp, Q)+++--------------------------------------------------------------------------------+-- | Embed template allows you embed a template within the Haskell binary.+-- Example:+--+-- > myTemplate :: Template+-- > myTemplate = $(embedTemplate "test.html")+embedTemplate :: FilePath -> Q Exp+embedTemplate filePath = [|+ let source = T.unpack $ T.decodeUtf8 $(embedFile filePath) in+ case parseTemplateElemsFile filePath source of+ Left err -> error err+ Right tpl -> template filePath tpl |]
+ lib/Hakyll/Web/Template/Context.hs view
@@ -0,0 +1,520 @@+-- | This module provides 'Context's which are used to expand expressions in+-- templates and allow for arbitrary customisation.+--+-- 'Template's define a small expression DSL which consists of strings,+-- identifiers and function application. There is no type system, every value is+-- a string and on the top level they get substituted verbatim into the page.+--+-- For example, you can build a context that contains+--+-- > … <> functionField "concat" (const . concat) <> …+--+-- which will allow you to use the @concat@ identifier as a function that takes+-- arbitrarily many strings and concatenates them to a new string:+--+-- > $partial(concat("templates/categories/", category))$+--+-- This will evaluate the @category@ field in the context, then prepend the path,+-- and include the referenced file as a template.+++--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+module Hakyll.Web.Template.Context+ ( ContextField (..)+ , Context (..)+ , field+ , boolField+ , boolFieldM+ , constField+ , listField+ , listFieldWith+ , functionField+ , mapContext+ , mapContextBy++ , defaultContext+ , bodyField+ , metadataField+ , urlField+ , pathField+ , titleField+ , snippetField+ , dateField+ , dateFieldWith+ , getItemUTC+ , getItemModificationTime+ , modificationTimeField+ , modificationTimeFieldWith+ , teaserField+ , teaserFieldWithSeparator+ , missingField+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative (Alternative (..))+import Control.Monad (msum)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.Functor.Contravariant (Contravariant (..))+import Data.Functor.Contravariant.Divisible (Divisible (..), Decidable (..))+import Data.List (intercalate, tails)+import Data.Time.Clock (UTCTime (..))+import Data.Time.Format (formatTime, parseTimeM)+import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)+import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Core.Provider+import Hakyll.Core.Util.String (needlePrefix, splitAll)+import Hakyll.Web.Html+import Prelude hiding (id)+import System.FilePath (dropExtension, splitDirectories,+ takeBaseName)++--------------------------------------------------------------------------------+-- | Mostly for internal usage+data ContextField+ = EmptyField+ | StringField String+ | forall a. ListField (Context a) [Item a]+++--------------------------------------------------------------------------------+-- | The 'Context' monoid. Please note that the order in which you+-- compose the items is important. For example in+--+-- > field "A" f1 <> field "A" f2+--+-- the first context will overwrite the second. This is especially+-- important when something is being composed with+-- 'metadataField' (or 'defaultContext'). If you want your context to be+-- overwritten by the metadata fields, compose it from the right:+--+-- @+-- 'metadataField' \<\> field \"date\" fDate+-- @+--+newtype Context a = Context+ { unContext :: String -> [String] -> Item a -> Compiler ContextField+ }+++--------------------------------------------------------------------------------+-- | Tries to find a key in the left context,+-- or when that fails in the right context.+instance Semigroup (Context a) where+ (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i++instance Monoid (Context a) where+ mempty = missingField+ mappend = (<>)++instance Contravariant Context where+ contramap f ctx = Context (\s ss -> unContext ctx s ss . fmap f)++instance Divisible Context where+ divide f c1 c2 = contramap (fst . f) c1 <> contramap (snd . f) c2+ conquer = missingField++instance Decidable Context where+ choose f (Context c1) (Context c2) = Context (\s ss (Item i e) ->+ either (c1 s ss . Item i) (c2 s ss . Item i) (f e))+ lose f = contramap f missingField++--------------------------------------------------------------------------------+field' :: String -> (Item a -> Compiler ContextField) -> Context a+field' key value = Context $ \k _ i ->+ if k == key+ then value i+ else noResult $ "Tried field " ++ key+++--------------------------------------------------------------------------------+-- | Constructs a new field for a 'Context'.+-- If the key matches, the compiler is run and its result is substituted in the+-- template.+--+-- If the compiler fails, the field will be considered non-existent+-- in an @$if()$@ macro or ultimately break the template application+-- (unless the key is found in another context when using '<>').+-- Use 'empty' or 'noResult' for intentional failures of fields used in+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'.+field+ :: String -- ^ Key+ -> (Item a -> Compiler String) -- ^ Function that constructs a value based+ -- on the item (e.g. accessing metadata)+ -> Context a+field key value = field' key (fmap StringField . value)+++--------------------------------------------------------------------------------+-- | Creates a 'field' to use with the @$if()$@ template macro.+-- Attempting to substitute the field into the template will cause an error.+boolField+ :: String -- ^ Key+ -> (Item a -> Bool) -- ^ Extract value from an @'Item' a@+ -> Context a+boolField name f = boolFieldM name (pure . f)+++--------------------------------------------------------------------------------+-- | Creates a 'field' to use with the @$if()$@ template macro, in the+-- 'Compiler' monad. Attempting to substitute the field into the template+-- will cause an error.+--+-- @since 4.16.4.0+boolFieldM+ :: String -- ^ Key+ -> (Item a -> Compiler Bool) -- ^ Extract value from an @'Item' a@+ -- from within the 'Compiler' monad+ -> Context a+boolFieldM name f = field' name (\i -> do+ b <- f i+ if b+ then return EmptyField+ else noResult $ "Field " ++ name ++ " is false")+++--------------------------------------------------------------------------------+-- | Creates a 'field' that does not depend on the 'Item' but always yields+-- the same string+constField :: String -- ^ Key+ -> String -- ^ Value+ -> Context a+constField key = field key . const . return+++--------------------------------------------------------------------------------+-- | Creates a list field to be consumed by a @$for(…)$@ expression.+-- The compiler returns multiple items which are rendered in the loop body+-- with the supplied context.+listField :: String -> Context a -> Compiler [Item a] -> Context b+listField key c xs = listFieldWith key c (const xs)+++--------------------------------------------------------------------------------+-- | Creates a list field like 'listField', but supplies the current page+-- to the compiler.+listFieldWith+ :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b+listFieldWith key c f = field' key $ fmap (ListField c) . f+++--------------------------------------------------------------------------------+-- | Creates a variadic function field.+--+-- The function will be called with the dynamically evaluated string arguments+-- from the template as well as the page that is currently rendered.+functionField :: String -- ^ Key+ -> ([String] -> Item a -> Compiler String) -- ^ Function+ -> Context a+functionField name value = Context $ \k args i ->+ if k == name+ then StringField <$> value args i+ else noResult $ "Tried function field " ++ name+++--------------------------------------------------------------------------------+-- | Transform the respective string results of all fields in a context.+-- For example,+--+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")+--+-- is equivalent to+--+-- > constField "x" "ac" <> constField "y" "bc"+--+mapContext :: (String -> String) -> Context a -> Context a+mapContext = mapContextBy (const True)+++--------------------------------------------------------------------------------+-- | Transform the respective string results of all fields in a context+-- satisfying a predicate. For example,+--+-- > mapContextBy (=="y") (++"c") (constField "x" "a" <> constField "y" "b")+--+-- is equivalent to+--+-- > constField "x" "a" <> constField "y" "bc"+--+mapContextBy :: (String -> Bool) -> (String -> String) -> Context a -> Context a+mapContextBy p f (Context c) = Context $ \k a i -> do+ fld <- c k a i+ case fld of+ EmptyField -> wrongType "boolField"+ StringField str -> return $ StringField $+ if p k then f str else str+ _ -> wrongType "ListField"+ where+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " +++ "can't map over a " ++ typ ++ "!"++--------------------------------------------------------------------------------+-- | A context that allows snippet inclusion. In processed file, use as:+--+-- > ...+-- > $snippet("path/to/snippet/")$+-- > ...+--+-- The contents of the included file will not be interpolated like @partial@+-- does it.+--+snippetField :: Context String+snippetField = functionField "snippet" f+ where+ f [contentsPath] _ = loadBody (fromFilePath contentsPath)+ f [] _ = fail "No argument to function 'snippet()'"+ f _ _ = fail "Too many arguments to function 'snippet()'"++--------------------------------------------------------------------------------+-- | A context that contains (in that order)+--+-- 1. A @$body$@ 'bodyField'+--+-- 2. Metadata fields+--+-- 3. A @$url$@ 'urlField'+--+-- 4. A @$path$@ 'pathField'+--+-- 5. A @$title$@ 'titleField'+--+-- This order means that all of the fields, except @$body$@,+-- can have their values replaced by metadata fields of the same name.+-- For example, a context from a file at @posts/foo.markdown@ has a default title+-- @foo@. However, with a metadata field:+--+-- > ---+-- > title: The Foo Story+-- > ---+--+-- The @$title$@ will be replaced with @The Foo Story@.+defaultContext :: Context String+defaultContext =+ bodyField "body" `mappend`+ metadataField `mappend`+ urlField "url" `mappend`+ pathField "path" `mappend`+ titleField "title"+++--------------------------------------------------------------------------------+teaserSeparator :: String+teaserSeparator = "<!--more-->"+++--------------------------------------------------------------------------------+-- | Body of the item, that is, the main content of the underlying file+bodyField :: String -> Context String+bodyField key = field key $ return . itemBody+++--------------------------------------------------------------------------------+-- | Map any field to its metadata value, if present+metadataField :: Context a+metadataField = Context $ \k _ i -> do+ let id = itemIdentifier i+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " +++ "of item " ++ show id+ value <- getMetadataField id k+ maybe empty' (return . StringField) value+++--------------------------------------------------------------------------------+-- | Absolute url to the resulting item. For an example item that produces a+-- file @posts/foo.html@, this field contains "posts/foo.html"+urlField :: String -> Context a+urlField key = field key $ \i -> do+ let id = itemIdentifier i+ empty' = fail $ "No route url found for item " ++ show id+ fmap (maybe empty' toUrl) $ getRoute id+++--------------------------------------------------------------------------------+-- | Filepath of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains+-- "posts/foo.markdown"+pathField :: String -> Context a+pathField key = field key $ return . toFilePath . itemIdentifier+++--------------------------------------------------------------------------------+-- | Basename of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains "foo"+titleField :: String -> Context a+titleField = mapContext takeBaseName . pathField+++--------------------------------------------------------------------------------+-- | When the metadata has a field called @published@ in one of the+-- following formats then this function can render the date.+--+-- * @Mon, 06 Sep 2010 00:01:00 +0000@+--+-- * @Mon, 06 Sep 2010 00:01:00 UTC@+--+-- * @Mon, 06 Sep 2010 00:01:00@+--+-- * @2010-09-06T00:01:00+0000@+--+-- * @2010-09-06T00:01:00Z@+--+-- * @2010-09-06T00:01:00@+--+-- * @2010-09-06 00:01:00+0000@+--+-- * @2010-09-06 00:01:00@+--+-- * @September 06, 2010 00:01 AM@+--+-- Following date-only formats are supported too (@00:00:00@ for time is+-- assumed)+--+-- * @2010-09-06@+--+-- * @06.09.2010@+--+-- * @September 06, 2010@+--+-- Alternatively, when the metadata has a field called @path@ in a+-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)+-- and no @published@ metadata field set, this function can render+-- the date. This pattern matches the file name or directory names+-- that begins with @yyyy-mm-dd@ . For example:+-- @folder//yyyy-mm-dd-title//dist//main.extension@ .+-- In case of multiple matches, the rightmost one is used.+--+-- As another alternative, if none of the above matches, and the file has a+-- path which contains nested directories specifying a date, then that date+-- will be used. In other words, if the path is of the form+-- @**//yyyy//mm//dd//**//main.extension@ .+-- As above, in case of multiple matches, the rightmost one is used.++dateField :: String -- ^ Key in which the rendered date should be placed+ -> String -- ^ Format to use on the date+ -> Context a -- ^ Resulting context+dateField = dateFieldWith defaultTimeLocale+++--------------------------------------------------------------------------------+-- | This is an extended version of 'dateField' that allows you to+-- specify a time locale that is used for outputting the date. For more+-- details, see 'dateField' and 'formatTime'.+dateFieldWith :: TimeLocale -- ^ Output time locale+ -> String -- ^ Destination key+ -> String -- ^ Format to use on the date+ -> Context a -- ^ Resulting context+dateFieldWith locale key format = field key $ \i -> do+ time <- getItemUTC locale $ itemIdentifier i+ return $ formatTime locale format time+++--------------------------------------------------------------------------------+-- | Parser to try to extract and parse the time from the @published@+-- field or from the filename. See 'dateField' for more information.+-- Exported for user convenience.+getItemUTC :: (MonadMetadata m, MonadFail m)+ => TimeLocale -- ^ Output time locale+ -> Identifier -- ^ Input page+ -> m UTCTime -- ^ Parsed UTCTime+getItemUTC locale id' = do+ metadata <- getMetadata id'+ let tryField k fmt = lookupString k metadata >>= parseTime' fmt+ paths = splitDirectories $ (dropExtension . toFilePath) id'++ maybe empty' return $ msum $+ [tryField "published" fmt | fmt <- formats] +++ [tryField "date" fmt | fmt <- formats] +++ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths] +++ [parseTime' "%Y-%m-%d" $ intercalate "-" $ fnCand | fnCand <- map (take 3) $ reverse . tails $ paths]+ where+ empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " +++ "could not parse time for " ++ show id'+ parseTime' = parseTimeM True locale+ formats =+ [ "%a, %d %b %Y %H:%M:%S %Z"+ , "%a, %d %b %Y %H:%M:%S"+ , "%Y-%m-%dT%H:%M:%S%Z"+ , "%Y-%m-%dT%H:%M:%S"+ , "%Y-%m-%d %H:%M:%S%Z"+ , "%Y-%m-%d %H:%M:%S"+ , "%Y-%m-%d"+ , "%d.%m.%Y"+ , "%B %e, %Y %l:%M %p"+ , "%B %e, %Y"+ , "%b %d, %Y"+ ]+++--------------------------------------------------------------------------------+-- | Get the time on which the actual file was last modified. This only works if+-- there actually is an underlying file, of couse.+getItemModificationTime+ :: Identifier+ -> Compiler UTCTime+getItemModificationTime identifier = do+ provider <- compilerProvider <$> compilerAsk+ return $ resourceModificationTime provider identifier+++--------------------------------------------------------------------------------+-- | Creates a field with the last modification date of the underlying item.+modificationTimeField :: String -- ^ Key+ -> String -- ^ Format+ -> Context a -- ^ Resulting context+modificationTimeField = modificationTimeFieldWith defaultTimeLocale+++--------------------------------------------------------------------------------+-- | Creates a field with the last modification date of the underlying item+-- in a custom localisation format (see 'formatTime').+modificationTimeFieldWith :: TimeLocale -- ^ Time output locale+ -> String -- ^ Key+ -> String -- ^ Format+ -> Context a -- ^ Resulting context+modificationTimeFieldWith locale key fmt = field key $ \i -> do+ mtime <- getItemModificationTime $ itemIdentifier i+ return $ formatTime locale fmt mtime+++--------------------------------------------------------------------------------+-- | A context with "teaser" key which contain a teaser of the item.+-- The item is loaded from the given snapshot (which should be saved+-- in the user code before any templates are applied).+teaserField :: String -- ^ Key to use+ -> Snapshot -- ^ Snapshot to load+ -> Context String -- ^ Resulting context+teaserField = teaserFieldWithSeparator teaserSeparator+++--------------------------------------------------------------------------------+-- | A context with "teaser" key which contain a teaser of the item, defined as+-- the snapshot content before the teaser separator. The item is loaded from the+-- given snapshot (which should be saved in the user code before any templates+-- are applied).+teaserFieldWithSeparator :: String -- ^ Separator to use+ -> String -- ^ Key to use+ -> Snapshot -- ^ Snapshot to load+ -> Context String -- ^ Resulting context+teaserFieldWithSeparator separator key snapshot = field key $ \item -> do+ body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot+ case needlePrefix separator body of+ Nothing -> fail $+ "Hakyll.Web.Template.Context: no teaser defined for " +++ show (itemIdentifier item)+ Just t -> return t+++--------------------------------------------------------------------------------+-- | Constantly reports any field as missing. Mostly for internal usage,+-- it is the last choice in every context used in a template application.+missingField :: Context a+missingField = Context $ \k _ _ -> noResult $+ "Missing field '" ++ k ++ "' in context"
+ lib/Hakyll/Web/Template/Internal.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hakyll.Web.Template.Internal+ ( Template (..)+ , template+ , templateBodyCompiler+ , templateCompiler+ , applyTemplate+ , loadAndApplyTemplate+ , applyAsTemplate+ , readTemplate+ , compileTemplateItem+ , unsafeReadTemplateFile++ , module Hakyll.Web.Template.Internal.Element+ , module Hakyll.Web.Template.Internal.Trim+ ) where+++--------------------------------------------------------------------------------+import Control.Monad.Except (catchError)+import Data.Binary (Binary)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Typeable (Typeable)+import GHC.Exts (IsString (..))+import GHC.Generics (Generic)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier+import Hakyll.Core.Item+import Hakyll.Core.Writable+import Hakyll.Web.Template.Context+import Hakyll.Web.Template.Internal.Element+import Hakyll.Web.Template.Internal.Trim+++--------------------------------------------------------------------------------+-- | Datatype used for template substitutions.+data Template = Template+ { tplElements :: [TemplateElement]+ , tplOrigin :: FilePath -- Only for error messages.+ } deriving (Show, Eq, Generic, Binary, Typeable)+++--------------------------------------------------------------------------------+instance Writable Template where+ -- Writing a template is impossible+ write _ _ = return ()+++--------------------------------------------------------------------------------+instance IsString Template where+ fromString = readTemplate+++--------------------------------------------------------------------------------+-- | Wrap the constructor to ensure trim is called.+template :: FilePath -> [TemplateElement] -> Template+template p = flip Template p . trim+++--------------------------------------------------------------------------------+-- | Parse a string into a template.+-- You should prefer 'compileTemplateItem' over this.+readTemplate :: String -> Template+readTemplate = either error (template origin) . parseTemplateElemsFile origin+ where+ origin = "{literal}"+{-# DEPRECATED readTemplate "Use templateCompiler instead" #-}++--------------------------------------------------------------------------------+-- | Parse an item body into a template.+-- Provides useful error messages in the 'Compiler' monad.+compileTemplateItem :: Item String -> Compiler Template+compileTemplateItem item = let file = itemIdentifier item+ in compileTemplateFile file (itemBody item)++--------------------------------------------------------------------------------+compileTemplateFile :: Identifier -> String -> Compiler Template+compileTemplateFile file = either fail (return . template origin)+ . parseTemplateElemsFile origin+ where+ origin = show file++--------------------------------------------------------------------------------+-- | Read a template, without metadata header+templateBodyCompiler :: Compiler (Item Template)+templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do+ item <- getResourceBody+ file <- getUnderlying+ withItemBody (compileTemplateFile file) item++--------------------------------------------------------------------------------+-- | Read complete file contents as a template+templateCompiler :: Compiler (Item Template)+templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do+ item <- getResourceString+ file <- getUnderlying+ withItemBody (compileTemplateFile file) item+++--------------------------------------------------------------------------------+-- | Interpolate template expressions from context values in a page+applyTemplate :: Template -- ^ Template+ -> Context a -- ^ Context+ -> Item a -- ^ Page+ -> Compiler (Item String) -- ^ Resulting item+applyTemplate tpl context item = do+ body <- applyTemplate' (tplElements tpl) context item `catchError` handler+ return $ itemSetBody body item+ where+ tplName = tplOrigin tpl+ itemName = show $ itemIdentifier item+ handler es = fail $ "Hakyll.Web.Template.applyTemplate: Failed to " +++ (if tplName == itemName+ then "interpolate template in item " ++ itemName+ else "apply template " ++ tplName ++ " to item " ++ itemName) +++ ":\n" ++ intercalate ",\n" es++++--------------------------------------------------------------------------------+applyTemplate'+ :: forall a.+ [TemplateElement] -- ^ Unwrapped Template+ -> Context a -- ^ Context+ -> Item a -- ^ Page+ -> Compiler String -- ^ Resulting item+applyTemplate' tes context x = go tes+ where+ context' :: String -> [String] -> Item a -> Compiler ContextField+ context' = unContext (context `mappend` missingField)++ go = fmap concat . mapM applyElem++ ---------------------------------------------------------------------------++ applyElem :: TemplateElement -> Compiler String++ applyElem TrimL = trimError++ applyElem TrimR = trimError++ applyElem (Chunk c) = return c++ applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e)+ where+ evalMsg = "In expr '$" ++ show e ++ "$'"+ typeMsg = "expr '$" ++ show e ++ "$'"++ applyElem Escaped = return "$"++ applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle+ where+ f = maybe (return "") go mf+ handle (Right _) = go t+ handle (Left (CompilationNoResult _)) = f+ handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f+ debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " +++ "[ERROR] in 'if' condition on expr '" ++ show e ++ "':")++ applyElem (For e b s) = withErrorMessage headMsg (applyExpr e) >>= \cf -> case cf of+ EmptyField -> expected "list" "boolean" typeMsg+ StringField _ -> expected "list" "string" typeMsg+ ListField c xs -> withErrorMessage bodyMsg $ do+ sep <- maybe (return "") go s+ bs <- mapM (applyTemplate' b c) xs+ return $ intercalate sep bs+ where+ headMsg = "In expr '$for(" ++ show e ++ ")$'"+ typeMsg = "loop expr '" ++ show e ++ "'"+ bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'"++ applyElem (Partial e) = withErrorMessage headMsg $+ applyStringExpr typeMsg e >>= \p ->+ withErrorMessage inclMsg $ do+ tpl' <- loadBody (fromFilePath p)+ itemBody <$> applyTemplate tpl' context x+ where+ headMsg = "In expr '$partial(" ++ show e ++ ")$'"+ typeMsg = "partial expr '" ++ show e ++ "'"+ inclMsg = "In inclusion of '$partial(" ++ show e ++ ")$'"++ ---------------------------------------------------------------------------++ applyExpr :: TemplateExpr -> Compiler ContextField++ applyExpr (Ident (TemplateKey k)) = context' k [] x++ applyExpr (Call (TemplateKey k) args) = do+ args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args+ context' k args' x+ where+ typeMsg e = "argument '" ++ show e ++ "'"++ applyExpr (StringLiteral s) = return (StringField s)++ ----------------------------------------------------------------------------++ applyStringExpr :: String -> TemplateExpr -> Compiler String+ applyStringExpr msg expr =+ applyExpr expr >>= getString+ where+ getString EmptyField = expected "string" "boolean" msg+ getString (StringField s) = return s+ getString (ListField _ _) = expected "string" "list" msg++ expected typ act expr = fail $ unwords ["Hakyll.Web.Template.applyTemplate:",+ "expected", typ, "but got", act, "for", expr]++ -- expected to never happen with all templates constructed by 'template'+ trimError = fail $+ "Hakyll.Web.Template.applyTemplate: template not fully trimmed."+++--------------------------------------------------------------------------------+-- | The following pattern is so common:+--+-- > tpl <- loadBody "templates/foo.html"+-- > someCompiler+-- > >>= applyTemplate tpl context+--+-- That we have a single function which does this:+--+-- > someCompiler+-- > >>= loadAndApplyTemplate "templates/foo.html" context+loadAndApplyTemplate :: Identifier -- ^ Template identifier+ -> Context a -- ^ Context+ -> Item a -- ^ Page+ -> Compiler (Item String) -- ^ Resulting item+loadAndApplyTemplate identifier context item = do+ tpl <- loadBody identifier+ applyTemplate tpl context item+++--------------------------------------------------------------------------------+-- | It is also possible that you want to substitute @$key$@s within the body of+-- an item. This function does that by interpreting the item body as a template,+-- and then applying it to itself.+applyAsTemplate :: Context String -- ^ Context+ -> Item String -- ^ Item and template+ -> Compiler (Item String) -- ^ Resulting item+applyAsTemplate context item = do+ tpl <- compileTemplateItem item+ applyTemplate tpl context item+++--------------------------------------------------------------------------------+unsafeReadTemplateFile :: FilePath -> Compiler Template+unsafeReadTemplateFile file = do+ tpl <- unsafeCompiler $ readFile file+ compileTemplateFile (fromFilePath file) tpl+{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}
+ lib/Hakyll/Web/Template/Internal/Element.hs view
@@ -0,0 +1,291 @@+--------------------------------------------------------------------------------+-- | Module containing the elements used in a template. A template is generally+-- just a list of these elements.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hakyll.Web.Template.Internal.Element+ ( TemplateKey (..)+ , TemplateExpr (..)+ , TemplateElement (..)+ , templateElems+ , parseTemplateElemsFile+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<|>))+import Control.Monad (void)+import Control.Arrow (left)+import Data.Binary (Binary, get, getWord8, put, putWord8)+import Data.List (intercalate)+import Data.Maybe (isJust)+import Data.Typeable (Typeable)+import GHC.Exts (IsString (..))+import qualified Text.Parsec as P+import qualified Text.Parsec.String as P+++--------------------------------------------------------------------------------+import Hakyll.Core.Util.Parser+++--------------------------------------------------------------------------------+newtype TemplateKey = TemplateKey String+ deriving (Binary, Show, Eq, Typeable)+++--------------------------------------------------------------------------------+instance IsString TemplateKey where+ fromString = TemplateKey+++--------------------------------------------------------------------------------+-- | Elements of a template.+data TemplateElement+ = Chunk String+ | Expr TemplateExpr+ | Escaped+ -- expr, then, else+ | If TemplateExpr [TemplateElement] (Maybe [TemplateElement])+ -- expr, body, separator+ | For TemplateExpr [TemplateElement] (Maybe [TemplateElement])+ -- filename+ | Partial TemplateExpr+ | TrimL+ | TrimR+ deriving (Show, Eq, Typeable)+++--------------------------------------------------------------------------------+instance Binary TemplateElement where+ put (Chunk string) = putWord8 0 >> put string+ put (Expr e) = putWord8 1 >> put e+ put Escaped = putWord8 2+ put (If e t f) = putWord8 3 >> put e >> put t >> put f+ put (For e b s) = putWord8 4 >> put e >> put b >> put s+ put (Partial e) = putWord8 5 >> put e+ put TrimL = putWord8 6+ put TrimR = putWord8 7++ get = getWord8 >>= \tag -> case tag of+ 0 -> Chunk <$> get+ 1 -> Expr <$> get+ 2 -> pure Escaped+ 3 -> If <$> get <*> get <*> get+ 4 -> For <$> get <*> get <*> get+ 5 -> Partial <$> get+ 6 -> pure TrimL+ 7 -> pure TrimR+ _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"+++--------------------------------------------------------------------------------+-- | Expression in a template+data TemplateExpr+ = Ident TemplateKey+ | Call TemplateKey [TemplateExpr]+ | StringLiteral String+ deriving (Eq, Typeable)+++--------------------------------------------------------------------------------+instance Show TemplateExpr where+ show (Ident (TemplateKey k)) = k+ show (Call (TemplateKey k) as) =+ k ++ "(" ++ intercalate ", " (map show as) ++ ")"+ show (StringLiteral s) = show s+++--------------------------------------------------------------------------------+instance Binary TemplateExpr where+ put (Ident k) = putWord8 0 >> put k+ put (Call k as) = putWord8 1 >> put k >> put as+ put (StringLiteral s) = putWord8 2 >> put s++ get = getWord8 >>= \tag -> case tag of+ 0 -> Ident <$> get+ 1 -> Call <$> get <*> get+ 2 -> StringLiteral <$> get+ _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"++--------------------------------------------------------------------------------+parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]+parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)+ . P.parse (templateElems <* P.eof) file+++--------------------------------------------------------------------------------+templateElems :: P.Parser [TemplateElement]+templateElems = mconcat <$> P.many (P.choice [ lift chunk+ , lift escaped+ , conditional+ , for+ , partial+ , expr+ ])+ where lift = fmap (:[])+++--------------------------------------------------------------------------------+chunk :: P.Parser TemplateElement+chunk = Chunk <$> P.many1 (P.noneOf "$")+++--------------------------------------------------------------------------------+expr :: P.Parser [TemplateElement]+expr = P.try $ do+ trimLExpr <- trimOpen+ e <- expr'+ trimRExpr <- trimClose+ return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]+++--------------------------------------------------------------------------------+expr' :: P.Parser TemplateExpr+expr' = stringLiteral <|> call <|> ident+++--------------------------------------------------------------------------------+escaped :: P.Parser TemplateElement+escaped = Escaped <$ P.try (P.string "$$")+++--------------------------------------------------------------------------------+trimOpen :: P.Parser Bool+trimOpen = do+ void $ P.char '$'+ trimLIf <- P.optionMaybe $ P.try (P.char '-')+ pure $ isJust trimLIf+++--------------------------------------------------------------------------------+trimClose :: P.Parser Bool+trimClose = do+ trimIfR <- P.optionMaybe $ (P.char '-')+ void $ P.char '$'+ pure $ isJust trimIfR+++--------------------------------------------------------------------------------+conditional :: P.Parser [TemplateElement]+conditional = P.try $ do+ -- if+ trimLIf <- trimOpen+ void $ P.string "if("+ e <- expr'+ void $ P.char ')'+ trimRIf <- trimClose+ -- then+ thenBranch <- templateElems+ -- else+ elseParse <- opt "else"+ -- endif+ trimLEnd <- trimOpen+ void $ P.string "endif"+ trimREnd <- trimClose++ -- As else is optional we need to sort out where any Trim_s need to go.+ let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse+ where thenNoElse =+ [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]++ thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)+ where thenB = [TrimR | trimRIf]+ ++ thenBranch+ ++ [TrimL | trimLElse]++ elseB = Just $ [TrimR | trimRElse]+ ++ elseBranch+ ++ [TrimL | trimLEnd]++ pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]+++--------------------------------------------------------------------------------+for :: P.Parser [TemplateElement]+for = P.try $ do+ -- for+ trimLFor <- trimOpen+ void $ P.string "for("+ e <- expr'+ void $ P.char ')'+ trimRFor <- trimClose+ -- body+ bodyBranch <- templateElems+ -- sep+ sepParse <- opt "sep"+ -- endfor+ trimLEnd <- trimOpen+ void $ P.string "endfor"+ trimREnd <- trimClose++ -- As sep is optional we need to sort out where any Trim_s need to go.+ let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse+ where forNoSep =+ [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]++ forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)+ where forB = [TrimR | trimRFor]+ ++ bodyBranch+ ++ [TrimL | trimLSep]++ sepB = Just $ [TrimR | trimRSep]+ ++ sepBranch+ ++ [TrimL | trimLEnd]++ pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]+++--------------------------------------------------------------------------------+partial :: P.Parser [TemplateElement]+partial = P.try $ do+ trimLPart <- trimOpen+ void $ P.string "partial("+ e <- expr'+ void $ P.char ')'+ trimRPart <- trimClose++ pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]+++--------------------------------------------------------------------------------+ident :: P.Parser TemplateExpr+ident = P.try $ Ident <$> key+++--------------------------------------------------------------------------------+call :: P.Parser TemplateExpr+call = P.try $ do+ f <- key+ void $ P.char '('+ P.spaces+ as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)+ P.spaces+ void $ P.char ')'+ return $ Call f as+++--------------------------------------------------------------------------------+stringLiteral :: P.Parser TemplateExpr+stringLiteral = do+ void $ P.char '\"'+ str <- P.many $ do+ x <- P.noneOf "\""+ if x == '\\' then P.anyChar else return x+ void $ P.char '\"'+ return $ StringLiteral str+++--------------------------------------------------------------------------------+key :: P.Parser TemplateKey+key = TemplateKey <$> metadataKey+++--------------------------------------------------------------------------------+opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))+opt clause = P.optionMaybe $ P.try $ do+ trimL <- trimOpen+ void $ P.string clause+ trimR <- trimClose+ branch <- templateElems+ pure (trimL, branch, trimR)+
+ lib/Hakyll/Web/Template/Internal/Trim.hs view
@@ -0,0 +1,95 @@+--------------------------------------------------------------------------------+-- | Module for trimming whitespace from tempaltes.+module Hakyll.Web.Template.Internal.Trim+ ( trim+ ) where+++--------------------------------------------------------------------------------+import Data.Char (isSpace)+import Data.List (dropWhileEnd)+++--------------------------------------------------------------------------------+import Hakyll.Web.Template.Internal.Element+++--------------------------------------------------------------------------------+trim :: [TemplateElement] -> [TemplateElement]+trim = cleanse . canonicalize+++--------------------------------------------------------------------------------+-- | Apply the Trim nodes to the Chunks.+cleanse :: [TemplateElement] -> [TemplateElement]+cleanse = recurse cleanse . process+ where process [] = []+ process (TrimR:Chunk str:ts) = let str' = dropWhile isSpace str+ in if null str'+ then process ts+ -- Might need to TrimL.+ else process $ Chunk str':ts++ process (Chunk str:TrimL:ts) = let str' = dropWhileEnd isSpace str+ in if null str'+ then process ts+ else Chunk str':process ts++ process (t:ts) = t:process ts++--------------------------------------------------------------------------------+-- | Enforce the invariant that:+--+-- * Every 'TrimL' has a 'Chunk' to its left.+-- * Every 'TrimR' has a 'Chunk' to its right.+--+canonicalize :: [TemplateElement] -> [TemplateElement]+canonicalize = go+ where go t = let t' = redundant . swap $ dedupe t+ in if t == t' then t else go t'+++--------------------------------------------------------------------------------+-- | Remove the 'TrimR' and 'TrimL's that are no-ops.+redundant :: [TemplateElement] -> [TemplateElement]+redundant = recurse redundant . process+ where -- Remove the leading 'TrimL's.+ process (TrimL:ts) = process ts+ -- Remove trailing 'TrimR's.+ process ts = foldr trailing [] ts+ where trailing TrimR [] = []+ trailing x xs = x:xs+++--------------------------------------------------------------------------------+-- >>> swap $ [TrimR, TrimL]+-- [TrimL, TrimR]+swap :: [TemplateElement] -> [TemplateElement]+swap = recurse swap . process+ where process [] = []+ process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts)+ process (t:ts) = t:process ts+++--------------------------------------------------------------------------------+-- | Remove 'TrimR' and 'TrimL' duplication.+dedupe :: [TemplateElement] -> [TemplateElement]+dedupe = recurse dedupe . process+ where process [] = []+ process (TrimR:TrimR:ts) = process (TrimR:ts)+ process (TrimL:TrimL:ts) = process (TrimL:ts)+ process (t:ts) = t:process ts+++--------------------------------------------------------------------------------+-- | @'recurse' f t@ applies f to every '[TemplateElement]' in t.+recurse :: ([TemplateElement] -> [TemplateElement])+ -> [TemplateElement]+ -> [TemplateElement]+recurse _ [] = []+recurse f (x:xs) = process x:recurse f xs+ where process y = case y of+ If e tb eb -> If e (f tb) (f <$> eb)+ For e t s -> For e (f t) (f <$> s)+ _ -> y+
+ lib/Hakyll/Web/Template/List.hs view
@@ -0,0 +1,95 @@+--------------------------------------------------------------------------------+-- | Provides an easy way to combine several items in a list. The applications+-- are obvious:+--+-- * A post list on a blog+--+-- * An image list in a gallery+--+-- * A sitemap+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+module Hakyll.Web.Template.List+ ( applyTemplateList+ , applyJoinTemplateList+ , chronological+ , recentFirst+ , sortChronological+ , sortRecentFirst+ ) where+++--------------------------------------------------------------------------------+import Control.Monad (liftM)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.List (intersperse, sortBy)+import Data.Ord (comparing)+import Data.Time.Locale.Compat (defaultTimeLocale)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Identifier+import Hakyll.Core.Item+import Hakyll.Core.Metadata+import Hakyll.Web.Template+import Hakyll.Web.Template.Context+++--------------------------------------------------------------------------------+-- | Generate a string of a listing of pages, after applying a template to each+-- page.+applyTemplateList :: Template+ -> Context a+ -> [Item a]+ -> Compiler String+applyTemplateList = applyJoinTemplateList ""+++--------------------------------------------------------------------------------+-- | Join a listing of pages with a string in between, after applying a template+-- to each page.+applyJoinTemplateList :: String+ -> Template+ -> Context a+ -> [Item a]+ -> Compiler String+applyJoinTemplateList delimiter tpl context items = do+ items' <- mapM (applyTemplate tpl context) items+ return $ concat $ intersperse delimiter $ map itemBody items'+++--------------------------------------------------------------------------------+-- | Sort pages chronologically. Uses the same method as 'dateField' for+-- extracting the date.+chronological :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a]+chronological =+ sortByM $ getItemUTC defaultTimeLocale . itemIdentifier+ where+ sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]+ sortByM f xs = liftM (map fst . sortBy (comparing snd)) $+ mapM (\x -> liftM (x,) (f x)) xs+++--------------------------------------------------------------------------------+-- | The reverse of 'chronological'+recentFirst :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a]+recentFirst = liftM reverse . chronological+++--------------------------------------------------------------------------------+-- | Version of 'chronological' which doesn't need the actual items.+sortChronological+ :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier]+sortChronological ids =+ liftM (map itemIdentifier) $ chronological [Item i () | i <- ids]+++--------------------------------------------------------------------------------+-- | Version of 'recentFirst' which doesn't need the actual items.+sortRecentFirst+ :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier]+sortRecentFirst ids =+ liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]
− src/Data/List/Extended.hs
@@ -1,15 +0,0 @@-module Data.List.Extended- ( module Data.List- , breakWhen- ) where--import Data.List---- | Like 'break', but can act on the entire tail of the list.-breakWhen :: ([a] -> Bool) -> [a] -> ([a], [a])-breakWhen predicate = go []- where- go buf [] = (reverse buf, [])- go buf (x : xs)- | predicate (x : xs) = (reverse buf, x : xs)- | otherwise = go (x : buf) xs
− src/Data/Yaml/Extended.hs
@@ -1,20 +0,0 @@-module Data.Yaml.Extended- ( module Data.Yaml- , toString- , toList- ) where--import qualified Data.Text as T-import qualified Data.Vector as V-import Data.Yaml--toString :: Value -> Maybe String-toString (String t) = Just (T.unpack t)-toString (Bool True) = Just "true"-toString (Bool False) = Just "false"-toString (Number d) = Just (show d)-toString _ = Nothing--toList :: Value -> Maybe [Value]-toList (Array a) = Just (V.toList a)-toList _ = Nothing
− src/Hakyll.hs
@@ -1,60 +0,0 @@------------------------------------------------------------------------------------ | Top-level module exporting all modules that are interesting for the user-{-# LANGUAGE CPP #-}-module Hakyll- ( module Hakyll.Core.Compiler- , module Hakyll.Core.Configuration- , module Hakyll.Core.File- , module Hakyll.Core.Identifier- , module Hakyll.Core.Identifier.Pattern- , module Hakyll.Core.Item- , module Hakyll.Core.Metadata- , module Hakyll.Core.Routes- , module Hakyll.Core.Rules- , module Hakyll.Core.UnixFilter- , module Hakyll.Core.Util.File- , module Hakyll.Core.Util.String- , module Hakyll.Core.Writable- , module Hakyll.Main- , module Hakyll.Web.CompressCss- , module Hakyll.Web.Feed- , module Hakyll.Web.Html- , module Hakyll.Web.Html.RelativizeUrls- , module Hakyll.Web.Pandoc- , module Hakyll.Web.Pandoc.Biblio- , module Hakyll.Web.Pandoc.FileType- , module Hakyll.Web.Tags- , module Hakyll.Web.Paginate- , module Hakyll.Web.Template- , module Hakyll.Web.Template.Context- , module Hakyll.Web.Template.List- ) where------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Configuration-import Hakyll.Core.File-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Core.Routes-import Hakyll.Core.Rules-import Hakyll.Core.UnixFilter-import Hakyll.Core.Util.File-import Hakyll.Core.Util.String-import Hakyll.Core.Writable-import Hakyll.Main-import Hakyll.Web.CompressCss-import Hakyll.Web.Feed-import Hakyll.Web.Html-import Hakyll.Web.Html.RelativizeUrls-import Hakyll.Web.Paginate-import Hakyll.Web.Pandoc-import Hakyll.Web.Pandoc.Biblio-import Hakyll.Web.Pandoc.FileType-import Hakyll.Web.Tags-import Hakyll.Web.Template-import Hakyll.Web.Template.Context-import Hakyll.Web.Template.List
− src/Hakyll/Check.hs
@@ -1,253 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Hakyll.Check- ( Check (..)- , check- ) where------------------------------------------------------------------------------------import Control.Monad (forM_)-import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWST, runRWST)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Resource (runResourceT)-import Control.Monad.Writer (tell)-import Data.List (isPrefixOf)-import Data.Set (Set)-import qualified Data.Set as S-import Network.URI (unEscapeString)-import System.Directory (doesDirectoryExist,- doesFileExist)-import System.Exit (ExitCode (..))-import System.FilePath (takeDirectory, takeExtension,- (</>))-import qualified Text.HTML.TagSoup as TS------------------------------------------------------------------------------------#ifdef CHECK_EXTERNAL-import Control.Exception (AsyncException (..),- SomeException (..), handle,- throw)-import Control.Monad.State (get, modify)-import Data.List (intercalate)-import Data.Typeable (cast)-import Data.Version (versionBranch)-import GHC.Exts (fromString)-import qualified Network.HTTP.Conduit as Http-import qualified Network.HTTP.Types as Http-import qualified Paths_hakyll as Paths_hakyll-#endif------------------------------------------------------------------------------------import Hakyll.Core.Configuration-import Hakyll.Core.Logger (Logger)-import qualified Hakyll.Core.Logger as Logger-import Hakyll.Core.Util.File-import Hakyll.Web.Html------------------------------------------------------------------------------------data Check = All | InternalLinks- deriving (Eq, Ord, Show)------------------------------------------------------------------------------------check :: Configuration -> Logger -> Check -> IO ExitCode-check config logger check' = do- ((), write) <- runChecker checkDestination config logger check'- return $ if checkerFaulty write > 0 then ExitFailure 1 else ExitSuccess------------------------------------------------------------------------------------data CheckerRead = CheckerRead- { checkerConfig :: Configuration- , checkerLogger :: Logger- , checkerCheck :: Check- }------------------------------------------------------------------------------------data CheckerWrite = CheckerWrite- { checkerFaulty :: Int- , checkerOk :: Int- } deriving (Show)------------------------------------------------------------------------------------instance Monoid CheckerWrite where- mempty = CheckerWrite 0 0- mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =- CheckerWrite (f1 + f2) (o1 + o2)------------------------------------------------------------------------------------type CheckerState = Set String------------------------------------------------------------------------------------type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a------------------------------------------------------------------------------------runChecker :: Checker a -> Configuration -> Logger -> Check- -> IO (a, CheckerWrite)-runChecker checker config logger check' = do- let read' = CheckerRead- { checkerConfig = config- , checkerLogger = logger- , checkerCheck = check'- }-- (x, _, write) <- runRWST checker read' S.empty- Logger.flush logger- return (x, write)------------------------------------------------------------------------------------checkDestination :: Checker ()-checkDestination = do- config <- checkerConfig <$> ask- files <- liftIO $ getRecursiveContents- (const $ return False) (destinationDirectory config)-- let htmls =- [ destinationDirectory config </> file- | file <- files- , takeExtension file == ".html"- ]-- forM_ htmls checkFile------------------------------------------------------------------------------------checkFile :: FilePath -> Checker ()-checkFile filePath = do- logger <- checkerLogger <$> ask- contents <- liftIO $ readFile filePath- Logger.header logger $ "Checking file " ++ filePath-- let urls = getUrls $ TS.parseTags contents- forM_ urls $ \url -> do- Logger.debug logger $ "Checking link " ++ url- checkUrl filePath url------------------------------------------------------------------------------------checkUrl :: FilePath -> String -> Checker ()-checkUrl filePath url- | isExternal url = checkExternalUrl url- | hasProtocol url = skip "Unknown protocol, skipping"- | otherwise = checkInternalUrl filePath url- where- validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."- hasProtocol str = case break (== ':') str of- (proto, ':' : _) -> all (`elem` validProtoChars) proto- _ -> False------------------------------------------------------------------------------------ok :: String -> Checker ()-ok _ = tell $ mempty {checkerOk = 1}------------------------------------------------------------------------------------skip :: String -> Checker ()-skip reason = do- logger <- checkerLogger <$> ask- Logger.debug logger $ reason- tell $ mempty {checkerOk = 1}-----------------------------------------------------------------------------------faulty :: String -> Checker ()-faulty url = do- logger <- checkerLogger <$> ask- Logger.error logger $ "Broken link to " ++ show url- tell $ mempty {checkerFaulty = 1}------------------------------------------------------------------------------------checkInternalUrl :: FilePath -> String -> Checker ()-checkInternalUrl base url = case url' of- "" -> ok url- _ -> do- config <- checkerConfig <$> ask- let dest = destinationDirectory config- dir = takeDirectory base- filePath- | "/" `isPrefixOf` url' = dest ++ url'- | otherwise = dir </> url'-- exists <- checkFileExists filePath- if exists then ok url else faulty url- where- url' = stripFragments $ unEscapeString url------------------------------------------------------------------------------------checkExternalUrl :: String -> Checker ()-#ifdef CHECK_EXTERNAL-checkExternalUrl url = do- logger <- checkerLogger <$> ask- needsCheck <- (== All) . checkerCheck <$> ask- checked <- (url `S.member`) <$> get-- if not needsCheck || checked- then Logger.debug logger "Already checked, skipping"- else do- isOk <- liftIO $ handle (failure logger) $ do- mgr <- Http.newManager Http.tlsManagerSettings- runResourceT $ do- request <- Http.parseUrl urlToCheck- response <- Http.http (settings request) mgr- let code = Http.statusCode (Http.responseStatus response)- return $ code >= 200 && code < 300-- modify $ if schemeRelative url- then S.insert urlToCheck . S.insert url- else S.insert url- if isOk then ok url else faulty url- where- -- Add additional request info- settings r = r- { Http.method = "HEAD"- , Http.redirectCount = 10- , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r- }-- -- Nice user agent info- ua = fromString $ "hakyll-check/" ++- (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version)-- -- Catch all the things except UserInterrupt- failure logger (SomeException e) = case cast e of- Just UserInterrupt -> throw UserInterrupt- _ -> Logger.error logger (show e) >> return False-- -- Check scheme-relative links- schemeRelative = isPrefixOf "//"- urlToCheck = if schemeRelative url then "http:" ++ url else url-#else-checkExternalUrl _ = return ()-#endif--------------------------------------------------------------------------------------- | Wraps doesFileExist, also checks for index.html-checkFileExists :: FilePath -> Checker Bool-checkFileExists filePath = liftIO $ do- file <- doesFileExist filePath- dir <- doesDirectoryExist filePath- case (file, dir) of- (True, _) -> return True- (_, True) -> doesFileExist $ filePath </> "index.html"- _ -> return False------------------------------------------------------------------------------------stripFragments :: String -> String-stripFragments = takeWhile (not . flip elem ['?', '#'])
− src/Hakyll/Commands.hs
@@ -1,162 +0,0 @@- ----------------------------------------------------------------------------------- | Implementation of Hakyll commands: build, preview...-{-# LANGUAGE CPP #-}-module Hakyll.Commands- ( build- , check- , clean- , preview- , rebuild- , server- , deploy- , watch- ) where------------------------------------------------------------------------------------import Control.Concurrent-import System.Exit (ExitCode, exitWith)-----------------------------------------------------------------------------------import qualified Hakyll.Check as Check-import Hakyll.Core.Configuration-import Hakyll.Core.Logger (Logger)-import qualified Hakyll.Core.Logger as Logger-import Hakyll.Core.Rules-import Hakyll.Core.Rules.Internal-import Hakyll.Core.Runtime-import Hakyll.Core.Util.File-----------------------------------------------------------------------------------#ifdef WATCH_SERVER-import Hakyll.Preview.Poll (watchUpdates)-#endif--#ifdef PREVIEW_SERVER-import Hakyll.Preview.Server-#endif--#ifdef mingw32_HOST_OS-import Control.Monad (void)-import System.IO.Error (catchIOError)-#endif-------------------------------------------------------------------------------------- | Build the site-build :: Configuration -> Logger -> Rules a -> IO ExitCode-build conf logger rules = fst <$> run conf logger rules-------------------------------------------------------------------------------------- | Run the checker and exit-check :: Configuration -> Logger -> Check.Check -> IO ()-check config logger check' = Check.check config logger check' >>= exitWith-------------------------------------------------------------------------------------- | Remove the output directories-clean :: Configuration -> Logger -> IO ()-clean conf logger = do- remove $ destinationDirectory conf- remove $ storeDirectory conf- remove $ tmpDirectory conf- where- remove dir = do- Logger.header logger $ "Removing " ++ dir ++ "..."- removeDirectory dir-------------------------------------------------------------------------------------- | Preview the site-preview :: Configuration -> Logger -> Rules a -> Int -> IO ()-#ifdef PREVIEW_SERVER-preview conf logger rules port = do- deprecatedMessage- watch conf logger "0.0.0.0" port True rules- where- deprecatedMessage = mapM_ putStrLn [ "The preview command has been deprecated."- , "Use the watch command for recompilation and serving."- ]-#else-preview _ _ _ _ = previewServerDisabled-#endif-------------------------------------------------------------------------------------- | Watch and recompile for changes--watch :: Configuration -> Logger -> String -> Int -> Bool -> Rules a -> IO ()-#ifdef WATCH_SERVER-watch conf logger host port runServer rules = do-#ifndef mingw32_HOST_OS- _ <- forkIO $ watchUpdates conf update-#else- -- Force windows users to compile with -threaded flag, as otherwise- -- thread is blocked indefinitely.- catchIOError (void $ forkOS $ watchUpdates conf update) $ do- fail $ "Hakyll.Commands.watch: Could not start update watching " ++- "thread. Did you compile with -threaded flag?"-#endif- server'- where- update = do- (_, ruleSet) <- run conf logger rules- return $ rulesPattern ruleSet- loop = threadDelay 100000 >> loop- server' = if runServer then server conf logger host port else loop-#else-watch _ _ _ _ _ _ = watchServerDisabled-#endif------------------------------------------------------------------------------------- | Rebuild the site-rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode-rebuild conf logger rules =- clean conf logger >> build conf logger rules------------------------------------------------------------------------------------- | Start a server-server :: Configuration -> Logger -> String -> Int -> IO ()-#ifdef PREVIEW_SERVER-server conf logger host port = do- let destination = destinationDirectory conf- staticServer logger destination preServeHook host port- where- preServeHook _ = return ()-#else-server _ _ _ _ = previewServerDisabled-#endif-------------------------------------------------------------------------------------- | Upload the site-deploy :: Configuration -> IO ExitCode-deploy conf = deploySite conf conf-------------------------------------------------------------------------------------- | Print a warning message about the preview serving not being enabled-#ifndef PREVIEW_SERVER-previewServerDisabled :: IO ()-previewServerDisabled =- mapM_ putStrLn- [ "PREVIEW SERVER"- , ""- , "The preview server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]-#endif--#ifndef WATCH_SERVER-watchServerDisabled :: IO ()-watchServerDisabled =- mapM_ putStrLn- [ "WATCH SERVER"- , ""- , "The watch server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]-#endif
− src/Hakyll/Core/Compiler.hs
@@ -1,180 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Hakyll.Core.Compiler- ( Compiler- , getUnderlying- , getUnderlyingExtension- , makeItem- , getRoute- , getResourceBody- , getResourceString- , getResourceLBS- , getResourceFilePath-- , Internal.Snapshot- , saveSnapshot- , Internal.load- , Internal.loadSnapshot- , Internal.loadBody- , Internal.loadSnapshotBody- , Internal.loadAll- , Internal.loadAllSnapshots-- , cached- , unsafeCompiler- , debugCompiler- ) where------------------------------------------------------------------------------------import Control.Monad (when)-import Data.Binary (Binary)-import Data.ByteString.Lazy (ByteString)-import Data.Typeable (Typeable)-import System.Environment (getProgName)-import System.FilePath (takeExtension)------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import qualified Hakyll.Core.Compiler.Require as Internal-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Core.Logger as Logger-import Hakyll.Core.Provider-import Hakyll.Core.Routes-import qualified Hakyll.Core.Store as Store-------------------------------------------------------------------------------------- | Get the underlying identifier.-getUnderlying :: Compiler Identifier-getUnderlying = compilerUnderlying <$> compilerAsk-------------------------------------------------------------------------------------- | Get the extension of the underlying identifier. Returns something like--- @".html"@-getUnderlyingExtension :: Compiler String-getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying------------------------------------------------------------------------------------makeItem :: a -> Compiler (Item a)-makeItem x = do- identifier <- getUnderlying- return $ Item identifier x-------------------------------------------------------------------------------------- | Get the route for a specified item-getRoute :: Identifier -> Compiler (Maybe FilePath)-getRoute identifier = do- provider <- compilerProvider <$> compilerAsk- routes <- compilerRoutes <$> compilerAsk- -- Note that this makes us dependend on that identifier: when the metadata- -- of that item changes, the route may change, hence we have to recompile- (mfp, um) <- compilerUnsafeIO $ runRoutes routes provider identifier- when um $ compilerTellDependencies [IdentifierDependency identifier]- return mfp-------------------------------------------------------------------------------------- | Get the full contents of the matched source file as a string,--- but without metadata preamble, if there was one.-getResourceBody :: Compiler (Item String)-getResourceBody = getResourceWith resourceBody-------------------------------------------------------------------------------------- | Get the full contents of the matched source file as a string.-getResourceString :: Compiler (Item String)-getResourceString = getResourceWith resourceString-------------------------------------------------------------------------------------- | Get the full contents of the matched source file as a lazy bytestring.-getResourceLBS :: Compiler (Item ByteString)-getResourceLBS = getResourceWith resourceLBS-------------------------------------------------------------------------------------- | Get the file path of the resource we are compiling-getResourceFilePath :: Compiler FilePath-getResourceFilePath = do- provider <- compilerProvider <$> compilerAsk- id' <- compilerUnderlying <$> compilerAsk- return $ resourceFilePath provider id'-------------------------------------------------------------------------------------- | Overloadable function for 'getResourceString' and 'getResourceLBS'-getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a)-getResourceWith reader = do- provider <- compilerProvider <$> compilerAsk- id' <- compilerUnderlying <$> compilerAsk- let filePath = toFilePath id'- if resourceExists provider id'- then compilerUnsafeIO $ Item id' <$> reader provider id'- else fail $ error' filePath- where- error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++- show fp ++ " not found"-------------------------------------------------------------------------------------- | Save a snapshot of the item. This function returns the same item, which--- convenient for building '>>=' chains.-saveSnapshot :: (Binary a, Typeable a)- => Internal.Snapshot -> Item a -> Compiler (Item a)-saveSnapshot snapshot item = do- store <- compilerStore <$> compilerAsk- logger <- compilerLogger <$> compilerAsk- compilerUnsafeIO $ do- Logger.debug logger $ "Storing snapshot: " ++ snapshot- Internal.saveSnapshot store snapshot item-- -- Signal that we saved the snapshot.- Compiler $ \_ -> return $ CompilerSnapshot snapshot (return item)------------------------------------------------------------------------------------cached :: (Binary a, Typeable a)- => String- -> Compiler a- -> Compiler a-cached name compiler = do- id' <- compilerUnderlying <$> compilerAsk- store <- compilerStore <$> compilerAsk- provider <- compilerProvider <$> compilerAsk- let modified = resourceModified provider id'- if modified- then do- x <- compiler- compilerUnsafeIO $ Store.set store [name, show id'] x- return x- else do- compilerTellCacheHits 1- x <- compilerUnsafeIO $ Store.get store [name, show id']- progName <- compilerUnsafeIO getProgName- case x of Store.Found x' -> return x'- _ -> fail $ error' progName- where- error' progName =- "Hakyll.Core.Compiler.cached: Cache corrupt! " ++- "Try running: " ++ progName ++ " clean"------------------------------------------------------------------------------------unsafeCompiler :: IO a -> Compiler a-unsafeCompiler = compilerUnsafeIO-------------------------------------------------------------------------------------- | Compiler for debugging purposes-debugCompiler :: String -> Compiler ()-debugCompiler msg = do- logger <- compilerLogger <$> compilerAsk- compilerUnsafeIO $ Logger.debug logger msg
− src/Hakyll/Core/Compiler/Internal.hs
@@ -1,265 +0,0 @@------------------------------------------------------------------------------------ | Internally used compiler module-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Hakyll.Core.Compiler.Internal- ( -- * Types- Snapshot- , CompilerRead (..)- , CompilerWrite (..)- , CompilerResult (..)- , Compiler (..)- , runCompiler-- -- * Core operations- , compilerTell- , compilerAsk- , compilerThrow- , compilerCatch- , compilerResult- , compilerUnsafeIO-- -- * Utilities- , compilerTellDependencies- , compilerTellCacheHits- ) where------------------------------------------------------------------------------------import Control.Applicative (Alternative (..))-import Control.Exception (SomeException, handle)-import Control.Monad (forM_)-import Control.Monad.Except (MonadError (..))-import Data.Set (Set)-import qualified Data.Set as S------------------------------------------------------------------------------------import Hakyll.Core.Configuration-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Logger (Logger)-import qualified Hakyll.Core.Logger as Logger-import Hakyll.Core.Metadata-import Hakyll.Core.Provider-import Hakyll.Core.Routes-import Hakyll.Core.Store-------------------------------------------------------------------------------------- | Whilst compiling an item, it possible to save multiple snapshots of it, and--- not just the final result.-type Snapshot = String-------------------------------------------------------------------------------------- | Environment in which a compiler runs-data CompilerRead = CompilerRead- { -- | Main configuration- compilerConfig :: Configuration- , -- | Underlying identifier- compilerUnderlying :: Identifier- , -- | Resource provider- compilerProvider :: Provider- , -- | List of all known identifiers- compilerUniverse :: Set Identifier- , -- | Site routes- compilerRoutes :: Routes- , -- | Compiler store- compilerStore :: Store- , -- | Logger- compilerLogger :: Logger- }------------------------------------------------------------------------------------data CompilerWrite = CompilerWrite- { compilerDependencies :: [Dependency]- , compilerCacheHits :: Int- } deriving (Show)------------------------------------------------------------------------------------instance Monoid CompilerWrite where- mempty = CompilerWrite [] 0- mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =- CompilerWrite (d1 ++ d2) (h1 + h2)------------------------------------------------------------------------------------data CompilerResult a where- CompilerDone :: a -> CompilerWrite -> CompilerResult a- CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a- CompilerError :: [String] -> CompilerResult a- CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a-------------------------------------------------------------------------------------- | A monad which lets you compile items and takes care of dependency tracking--- for you.-newtype Compiler a = Compiler- { unCompiler :: CompilerRead -> IO (CompilerResult a)- }------------------------------------------------------------------------------------instance Functor Compiler where- fmap f (Compiler c) = Compiler $ \r -> do- res <- c r- return $ case res of- CompilerDone x w -> CompilerDone (f x) w- CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')- CompilerError e -> CompilerError e- CompilerRequire i c' -> CompilerRequire i (fmap f c')- {-# INLINE fmap #-}------------------------------------------------------------------------------------instance Monad Compiler where- return x = Compiler $ \_ -> return $ CompilerDone x mempty- {-# INLINE return #-}-- Compiler c >>= f = Compiler $ \r -> do- res <- c r- case res of- CompilerDone x w -> do- res' <- unCompiler (f x) r- return $ case res' of- CompilerDone y w' -> CompilerDone y (w `mappend` w')- CompilerSnapshot s c' -> CompilerSnapshot s $ do- compilerTell w -- Save dependencies!- c'- CompilerError e -> CompilerError e- CompilerRequire i c' -> CompilerRequire i $ do- compilerTell w -- Save dependencies!- c'-- CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)- CompilerError e -> return $ CompilerError e- CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)- {-# INLINE (>>=) #-}-- fail = compilerThrow . return- {-# INLINE fail #-}------------------------------------------------------------------------------------instance Applicative Compiler where- pure x = return x- {-# INLINE pure #-}-- f <*> x = f >>= \f' -> fmap f' x- {-# INLINE (<*>) #-}------------------------------------------------------------------------------------instance MonadMetadata Compiler where- getMetadata = compilerGetMetadata- getMatches = compilerGetMatches------------------------------------------------------------------------------------instance MonadError [String] Compiler where- throwError = compilerThrow- catchError = compilerCatch------------------------------------------------------------------------------------runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)-runCompiler compiler read' = handle handler $ unCompiler compiler read'- where- handler :: SomeException -> IO (CompilerResult a)- handler e = return $ CompilerError [show e]------------------------------------------------------------------------------------instance Alternative Compiler where- empty = compilerThrow []- x <|> y = compilerCatch x $ \es -> do- logger <- compilerLogger <$> compilerAsk- forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $- "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e- y- {-# INLINE (<|>) #-}------------------------------------------------------------------------------------compilerAsk :: Compiler CompilerRead-compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty-{-# INLINE compilerAsk #-}------------------------------------------------------------------------------------compilerTell :: CompilerWrite -> Compiler ()-compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps-{-# INLINE compilerTell #-}------------------------------------------------------------------------------------compilerThrow :: [String] -> Compiler a-compilerThrow es = Compiler $ \_ -> return $ CompilerError es-{-# INLINE compilerThrow #-}------------------------------------------------------------------------------------compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a-compilerCatch (Compiler x) f = Compiler $ \r -> do- res <- x r- case res of- CompilerDone res' w -> return (CompilerDone res' w)- CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))- CompilerError e -> unCompiler (f e) r- CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))-{-# INLINE compilerCatch #-}-------------------------------------------------------------------------------------- | Put the result back in a compiler-compilerResult :: CompilerResult a -> Compiler a-compilerResult x = Compiler $ \_ -> return x-{-# INLINE compilerResult #-}------------------------------------------------------------------------------------compilerUnsafeIO :: IO a -> Compiler a-compilerUnsafeIO io = Compiler $ \_ -> do- x <- io- return $ CompilerDone x mempty-{-# INLINE compilerUnsafeIO #-}------------------------------------------------------------------------------------compilerTellDependencies :: [Dependency] -> Compiler ()-compilerTellDependencies ds = do- logger <- compilerLogger <$> compilerAsk- forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $- "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d- compilerTell mempty {compilerDependencies = ds}-{-# INLINE compilerTellDependencies #-}------------------------------------------------------------------------------------compilerTellCacheHits :: Int -> Compiler ()-compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}-{-# INLINE compilerTellCacheHits #-}------------------------------------------------------------------------------------compilerGetMetadata :: Identifier -> Compiler Metadata-compilerGetMetadata identifier = do- provider <- compilerProvider <$> compilerAsk- compilerTellDependencies [IdentifierDependency identifier]- compilerUnsafeIO $ resourceMetadata provider identifier------------------------------------------------------------------------------------compilerGetMatches :: Pattern -> Compiler [Identifier]-compilerGetMatches pattern = do- universe <- compilerUniverse <$> compilerAsk- let matching = filterMatches pattern $ S.toList universe- set' = S.fromList matching- compilerTellDependencies [PatternDependency pattern set']- return matching
− src/Hakyll/Core/Compiler/Require.hs
@@ -1,121 +0,0 @@----------------------------------------------------------------------------------module Hakyll.Core.Compiler.Require- ( Snapshot- , save- , saveSnapshot- , load- , loadSnapshot- , loadBody- , loadSnapshotBody- , loadAll- , loadAllSnapshots- ) where------------------------------------------------------------------------------------import Control.Monad (when)-import Data.Binary (Binary)-import qualified Data.Set as S-import Data.Typeable------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Core.Store (Store)-import qualified Hakyll.Core.Store as Store------------------------------------------------------------------------------------save :: (Binary a, Typeable a) => Store -> Item a -> IO ()-save store item = saveSnapshot store final item-------------------------------------------------------------------------------------- | Save a specific snapshot of an item, so you can load it later using--- 'loadSnapshot'.-saveSnapshot :: (Binary a, Typeable a)- => Store -> Snapshot -> Item a -> IO ()-saveSnapshot store snapshot item =- Store.set store (key (itemIdentifier item) snapshot) (itemBody item)-------------------------------------------------------------------------------------- | Load an item compiled elsewhere. If the required item is not yet compiled,--- the build system will take care of that automatically.-load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)-load id' = loadSnapshot id' final-------------------------------------------------------------------------------------- | Require a specific snapshot of an item.-loadSnapshot :: (Binary a, Typeable a)- => Identifier -> Snapshot -> Compiler (Item a)-loadSnapshot id' snapshot = do- store <- compilerStore <$> compilerAsk- universe <- compilerUniverse <$> compilerAsk-- -- Quick check for better error messages- when (id' `S.notMember` universe) $ fail notFound-- compilerTellDependencies [IdentifierDependency id']- compilerResult $ CompilerRequire (id', snapshot) $ do- result <- compilerUnsafeIO $ Store.get store (key id' snapshot)- case result of- Store.NotFound -> fail notFound- Store.WrongType e r -> fail $ wrongType e r- Store.Found x -> return $ Item id' x- where- notFound =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was not found in the cache, " ++- "the cache might be corrupted or " ++- "the item you are referring to might not exist"- wrongType e r =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was found in the cache, " ++- "but does not have the right type: expected " ++ show e ++- " but got " ++ show r-------------------------------------------------------------------------------------- | A shortcut for only requiring the body of an item.------ > loadBody = fmap itemBody . load-loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a-loadBody id' = loadSnapshotBody id' final------------------------------------------------------------------------------------loadSnapshotBody :: (Binary a, Typeable a)- => Identifier -> Snapshot -> Compiler a-loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot-------------------------------------------------------------------------------------- | This function allows you to 'load' a dynamic list of items-loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]-loadAll pattern = loadAllSnapshots pattern final------------------------------------------------------------------------------------loadAllSnapshots :: (Binary a, Typeable a)- => Pattern -> Snapshot -> Compiler [Item a]-loadAllSnapshots pattern snapshot = do- matching <- getMatches pattern- mapM (\i -> loadSnapshot i snapshot) matching------------------------------------------------------------------------------------key :: Identifier -> String -> [String]-key identifier snapshot =- ["Hakyll.Core.Compiler.Require", show identifier, snapshot]------------------------------------------------------------------------------------final :: Snapshot-final = "_final"
− src/Hakyll/Core/Configuration.hs
@@ -1,134 +0,0 @@------------------------------------------------------------------------------------ | Exports a datastructure for the top-level hakyll configuration-module Hakyll.Core.Configuration- ( Configuration (..)- , shouldIgnoreFile- , defaultConfiguration- ) where------------------------------------------------------------------------------------import Data.Default (Default (..))-import Data.List (isPrefixOf, isSuffixOf)-import System.Directory (canonicalizePath)-import System.Exit (ExitCode)-import System.FilePath (isAbsolute, normalise, takeFileName)-import System.IO.Error (catchIOError)-import System.Process (system)------------------------------------------------------------------------------------data Configuration = Configuration- { -- | Directory in which the output written- destinationDirectory :: FilePath- , -- | Directory where hakyll's internal store is kept- storeDirectory :: FilePath- , -- | Directory in which some temporary files will be kept- tmpDirectory :: FilePath- , -- | Directory where hakyll finds the files to compile. This is @.@ by- -- default.- providerDirectory :: FilePath- , -- | Function to determine ignored files- --- -- In 'defaultConfiguration', the following files are ignored:- --- -- * files starting with a @.@- --- -- * files starting with a @#@- --- -- * files ending with a @~@- --- -- * files ending with @.swp@- --- -- Note that the files in 'destinationDirectory' and 'storeDirectory' will- -- also be ignored. Note that this is the configuration parameter, if you- -- want to use the test, you should use 'shouldIgnoreFile'.- --- ignoreFile :: FilePath -> Bool- , -- | Here, you can plug in a system command to upload/deploy your site.- --- -- Example:- --- -- > rsync -ave 'ssh -p 2217' _site jaspervdj@jaspervdj.be:hakyll- --- -- You can execute this by using- --- -- > ./site deploy- --- deployCommand :: String- , -- | Function to deploy the site from Haskell.- --- -- By default, this command executes the shell command stored in- -- 'deployCommand'. If you override it, 'deployCommand' will not- -- be used implicitely.- --- -- The 'Configuration' object is passed as a parameter to this- -- function.- --- deploySite :: Configuration -> IO ExitCode- , -- | Use an in-memory cache for items. This is faster but uses more- -- memory.- inMemoryCache :: Bool- , -- | Override default host for preview server. Default is "127.0.0.1",- -- which binds only on the loopback address.- -- One can also override the host as a command line argument:- -- ./site preview -h "0.0.0.0"- previewHost :: String- , -- | Override default port for preview server. Default is 8000.- -- One can also override the port as a command line argument:- -- ./site preview -p 1234- previewPort :: Int- }-----------------------------------------------------------------------------------instance Default Configuration where- def = defaultConfiguration------------------------------------------------------------------------------------- | Default configuration for a hakyll application-defaultConfiguration :: Configuration-defaultConfiguration = Configuration- { destinationDirectory = "_site"- , storeDirectory = "_cache"- , tmpDirectory = "_cache/tmp"- , providerDirectory = "."- , ignoreFile = ignoreFile'- , deployCommand = "echo 'No deploy command specified' && exit 1"- , deploySite = system . deployCommand- , inMemoryCache = True- , previewHost = "127.0.0.1"- , previewPort = 8000- }- where- ignoreFile' path- | "." `isPrefixOf` fileName = True- | "#" `isPrefixOf` fileName = True- | "~" `isSuffixOf` fileName = True- | ".swp" `isSuffixOf` fileName = True- | otherwise = False- where- fileName = takeFileName path-------------------------------------------------------------------------------------- | Check if a file should be ignored-shouldIgnoreFile :: Configuration -> FilePath -> IO Bool-shouldIgnoreFile conf path = orM- [ inDir (destinationDirectory conf)- , inDir (storeDirectory conf)- , inDir (tmpDirectory conf)- , return (ignoreFile conf path')- ]- where- path' = normalise path- absolute = isAbsolute path-- inDir dir- | absolute = do- dir' <- catchIOError (canonicalizePath dir) (const $ return dir)- return $ dir' `isPrefixOf` path'- | otherwise = return $ dir `isPrefixOf` path'-- orM :: [IO Bool] -> IO Bool- orM [] = return False- orM (x : xs) = x >>= \b -> if b then return True else orM xs
− src/Hakyll/Core/Dependencies.hs
@@ -1,146 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-module Hakyll.Core.Dependencies- ( Dependency (..)- , DependencyFacts- , outOfDate- ) where------------------------------------------------------------------------------------import Control.Monad (foldM, forM_, unless, when)-import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWS, runRWS)-import qualified Control.Monad.State as State-import Control.Monad.Writer (tell)-import Data.Binary (Binary (..), getWord8,- putWord8)-import Data.List (find)-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as S-import Data.Typeable (Typeable)------------------------------------------------------------------------------------import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern------------------------------------------------------------------------------------data Dependency- = PatternDependency Pattern (Set Identifier)- | IdentifierDependency Identifier- deriving (Show, Typeable)------------------------------------------------------------------------------------instance Binary Dependency where- put (PatternDependency p is) = putWord8 0 >> put p >> put is- put (IdentifierDependency i) = putWord8 1 >> put i- get = getWord8 >>= \t -> case t of- 0 -> PatternDependency <$> get <*> get- 1 -> IdentifierDependency <$> get- _ -> error "Data.Binary.get: Invalid Dependency"------------------------------------------------------------------------------------type DependencyFacts = Map Identifier [Dependency]------------------------------------------------------------------------------------outOfDate- :: [Identifier] -- ^ All known identifiers- -> Set Identifier -- ^ Initially out-of-date resources- -> DependencyFacts -- ^ Old dependency facts- -> (Set Identifier, DependencyFacts, [String])-outOfDate universe ood oldFacts =- let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood)- in (dependencyOod state, dependencyFacts state, logs)- where- rws = do- checkNew- checkChangedPatterns- bruteForce------------------------------------------------------------------------------------data DependencyState = DependencyState- { dependencyFacts :: DependencyFacts- , dependencyOod :: Set Identifier- } deriving (Show)------------------------------------------------------------------------------------type DependencyM a = RWS [Identifier] [String] DependencyState a------------------------------------------------------------------------------------markOod :: Identifier -> DependencyM ()-markOod id' = State.modify $ \s ->- s {dependencyOod = S.insert id' $ dependencyOod s}------------------------------------------------------------------------------------dependenciesFor :: Identifier -> DependencyM [Identifier]-dependenciesFor id' = do- facts <- dependencyFacts <$> State.get- return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts- where- dependenciesFor' (IdentifierDependency i) = [i]- dependenciesFor' (PatternDependency _ is) = S.toList is------------------------------------------------------------------------------------checkNew :: DependencyM ()-checkNew = do- universe <- ask- facts <- dependencyFacts <$> State.get- forM_ universe $ \id' -> unless (id' `M.member` facts) $ do- tell [show id' ++ " is out-of-date because it is new"]- markOod id'------------------------------------------------------------------------------------checkChangedPatterns :: DependencyM ()-checkChangedPatterns = do- facts <- M.toList . dependencyFacts <$> State.get- forM_ facts $ \(id', deps) -> do- deps' <- foldM (go id') [] deps- State.modify $ \s -> s- {dependencyFacts = M.insert id' deps' $ dependencyFacts s}- where- go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds- go id' ds (PatternDependency p ls) = do- universe <- ask- let ls' = S.fromList $ filterMatches p universe- if ls == ls'- then return $ PatternDependency p ls : ds- else do- tell [show id' ++ " is out-of-date because a pattern changed"]- markOod id'- return $ PatternDependency p ls' : ds------------------------------------------------------------------------------------bruteForce :: DependencyM ()-bruteForce = do- todo <- ask- go todo- where- go todo = do- (todo', changed) <- foldM check ([], False) todo- when changed (go todo')-- check (todo, changed) id' = do- deps <- dependenciesFor id'- ood <- dependencyOod <$> State.get- case find (`S.member` ood) deps of- Nothing -> return (id' : todo, changed)- Just d -> do- tell [show id' ++ " is out-of-date because " ++- show d ++ " is out-of-date"]- markOod id'- return (todo, True)
− src/Hakyll/Core/File.hs
@@ -1,85 +0,0 @@------------------------------------------------------------------------------------ | Exports simple compilers to just copy files-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Hakyll.Core.File- ( CopyFile (..)- , copyFileCompiler- , TmpFile (..)- , newTmpFile- ) where------------------------------------------------------------------------------------import Data.Binary (Binary (..))-import Data.Typeable (Typeable)-import System.Directory (copyFile, doesFileExist,- renameFile)-import System.FilePath ((</>))-import System.Random (randomIO)------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Configuration-import Hakyll.Core.Item-import Hakyll.Core.Provider-import qualified Hakyll.Core.Store as Store-import Hakyll.Core.Util.File-import Hakyll.Core.Writable-------------------------------------------------------------------------------------- | This will copy any file directly by using a system call-newtype CopyFile = CopyFile FilePath- deriving (Binary, Eq, Ord, Show, Typeable)------------------------------------------------------------------------------------instance Writable CopyFile where- write dst (Item _ (CopyFile src)) = copyFile src dst------------------------------------------------------------------------------------copyFileCompiler :: Compiler (Item CopyFile)-copyFileCompiler = do- identifier <- getUnderlying- provider <- compilerProvider <$> compilerAsk- makeItem $ CopyFile $ resourceFilePath provider identifier------------------------------------------------------------------------------------newtype TmpFile = TmpFile FilePath- deriving (Typeable)------------------------------------------------------------------------------------instance Binary TmpFile where- put _ = return ()- get = error $- "Hakyll.Core.File.TmpFile: You tried to load a TmpFile, however, " ++- "this is not possible since these are deleted as soon as possible."------------------------------------------------------------------------------------instance Writable TmpFile where- write dst (Item _ (TmpFile fp)) = renameFile fp dst-------------------------------------------------------------------------------------- | Create a tmp file-newTmpFile :: String -- ^ Suffix and extension- -> Compiler TmpFile -- ^ Resulting tmp path-newTmpFile suffix = do- path <- mkPath- compilerUnsafeIO $ makeDirectories path- debugCompiler $ "newTmpFile " ++ path- return $ TmpFile path- where- mkPath = do- rand <- compilerUnsafeIO $ randomIO :: Compiler Int- tmp <- tmpDirectory . compilerConfig <$> compilerAsk- let path = tmp </> Store.hash [show rand] ++ "-" ++ suffix- exists <- compilerUnsafeIO $ doesFileExist path- if exists then mkPath else return path
− src/Hakyll/Core/Identifier.hs
@@ -1,80 +0,0 @@------------------------------------------------------------------------------------ | An identifier is a type used to uniquely identify an item. An identifier is--- conceptually similar to a file path. Examples of identifiers are:------ * @posts/foo.markdown@------ * @index@------ * @error/404@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Hakyll.Core.Identifier- ( Identifier- , fromFilePath- , toFilePath- , identifierVersion- , setVersion- ) where------------------------------------------------------------------------------------import Control.DeepSeq (NFData (..))-import Data.List (intercalate)-import System.FilePath (dropTrailingPathSeparator, splitPath)------------------------------------------------------------------------------------import Data.Binary (Binary (..))-import Data.Typeable (Typeable)-import GHC.Exts (IsString, fromString)------------------------------------------------------------------------------------data Identifier = Identifier- { identifierVersion :: Maybe String- , identifierPath :: String- } deriving (Eq, Ord, Typeable)------------------------------------------------------------------------------------instance Binary Identifier where- put (Identifier v p) = put v >> put p- get = Identifier <$> get <*> get------------------------------------------------------------------------------------instance IsString Identifier where- fromString = fromFilePath------------------------------------------------------------------------------------instance NFData Identifier where- rnf (Identifier v p) = rnf v `seq` rnf p `seq` ()------------------------------------------------------------------------------------instance Show Identifier where- show i = case identifierVersion i of- Nothing -> toFilePath i- Just v -> toFilePath i ++ " (" ++ v ++ ")"-------------------------------------------------------------------------------------- | Parse an identifier from a string-fromFilePath :: String -> Identifier-fromFilePath = Identifier Nothing .- intercalate "/" . filter (not . null) . split'- where- split' = map dropTrailingPathSeparator . splitPath-------------------------------------------------------------------------------------- | Convert an identifier to a relative 'FilePath'-toFilePath :: Identifier -> FilePath-toFilePath = identifierPath------------------------------------------------------------------------------------setVersion :: Maybe String -> Identifier -> Identifier-setVersion v i = i {identifierVersion = v}
− src/Hakyll/Core/Identifier/Pattern.hs
@@ -1,322 +0,0 @@------------------------------------------------------------------------------------ | As 'Identifier' is used to specify a single item, a 'Pattern' is used to--- specify a list of items.------ In most cases, globs are used for patterns.------ A very simple pattern of such a pattern is @\"foo\/bar\"@. This pattern will--- only match the exact @foo\/bar@ identifier.------ To match more than one identifier, there are different captures that one can--- use:------ * @\"*\"@: matches at most one element of an identifier;------ * @\"**\"@: matches one or more elements of an identifier.------ Some examples:------ * @\"foo\/*\"@ will match @\"foo\/bar\"@ and @\"foo\/foo\"@, but not--- @\"foo\/bar\/qux\"@;------ * @\"**\"@ will match any identifier;------ * @\"foo\/**\"@ will match @\"foo\/bar\"@ and @\"foo\/bar\/qux\"@, but not--- @\"bar\/foo\"@;------ * @\"foo\/*.html\"@ will match all HTML files in the @\"foo\/\"@ directory.------ The 'capture' function allows the user to get access to the elements captured--- by the capture elements in the pattern.-module Hakyll.Core.Identifier.Pattern- ( -- * The pattern type- Pattern-- -- * Creating patterns- , fromGlob- , fromList- , fromRegex- , fromVersion- , hasVersion- , hasNoVersion-- -- * Composing patterns- , (.&&.)- , (.||.)- , complement-- -- * Applying patterns- , matches- , filterMatches-- -- * Capturing strings- , capture- , fromCapture- , fromCaptures- ) where------------------------------------------------------------------------------------import Control.Arrow ((&&&), (>>>))-import Control.Monad (msum)-import Data.Binary (Binary (..), getWord8, putWord8)-import Data.List (inits, isPrefixOf, tails)-import Data.Maybe (isJust)-import Data.Set (Set)-import qualified Data.Set as S------------------------------------------------------------------------------------import GHC.Exts (IsString, fromString)-import Text.Regex.TDFA ((=~))------------------------------------------------------------------------------------import Hakyll.Core.Identifier-------------------------------------------------------------------------------------- | Elements of a glob pattern-data GlobComponent- = Capture- | CaptureMany- | Literal String- deriving (Eq, Show)------------------------------------------------------------------------------------instance Binary GlobComponent where- put Capture = putWord8 0- put CaptureMany = putWord8 1- put (Literal s) = putWord8 2 >> put s-- get = getWord8 >>= \t -> case t of- 0 -> pure Capture- 1 -> pure CaptureMany- 2 -> Literal <$> get- _ -> error "Data.Binary.get: Invalid GlobComponent"-------------------------------------------------------------------------------------- | Type that allows matching on identifiers-data Pattern- = Everything- | Complement Pattern- | And Pattern Pattern- | Glob [GlobComponent]- | List (Set Identifier)- | Regex String- | Version (Maybe String)- deriving (Show)------------------------------------------------------------------------------------instance Binary Pattern where- put Everything = putWord8 0- put (Complement p) = putWord8 1 >> put p- put (And x y) = putWord8 2 >> put x >> put y- put (Glob g) = putWord8 3 >> put g- put (List is) = putWord8 4 >> put is- put (Regex r) = putWord8 5 >> put r- put (Version v) = putWord8 6 >> put v-- get = getWord8 >>= \t -> case t of- 0 -> pure Everything- 1 -> Complement <$> get- 2 -> And <$> get <*> get- 3 -> Glob <$> get- 4 -> List <$> get- 5 -> Regex <$> get- _ -> Version <$> get------------------------------------------------------------------------------------instance IsString Pattern where- fromString = fromGlob------------------------------------------------------------------------------------instance Monoid Pattern where- mempty = Everything- mappend = (.&&.)-------------------------------------------------------------------------------------- | Parse a pattern from a string-fromGlob :: String -> Pattern-fromGlob = Glob . parse'- where- parse' str =- let (chunk, rest) = break (`elem` "\\*") str- in case rest of- ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs- ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs- ('*' : xs) -> Literal chunk : Capture : parse' xs- xs -> Literal chunk : Literal xs : []-------------------------------------------------------------------------------------- | Create a 'Pattern' from a list of 'Identifier's it should match.------ /Warning/: use this carefully with 'hasNoVersion' and 'hasVersion'. The--- 'Identifier's in the list /already/ have versions assigned, and the pattern--- will then only match the intersection of both versions.------ A more concrete example,------ > fromList ["foo.markdown"] .&&. hasVersion "pdf"------ will not match anything! The @"foo.markdown"@ 'Identifier' has no version--- assigned, so the LHS of '.&&.' will only match this 'Identifier' with no--- version. The RHS only matches 'Identifier's with version set to @"pdf"@ ----- hence, this pattern matches nothing.------ The correct way to use this is:------ > fromList $ map (setVersion $ Just "pdf") ["foo.markdown"]-fromList :: [Identifier] -> Pattern-fromList = List . S.fromList-------------------------------------------------------------------------------------- | Create a 'Pattern' from a regex------ Example:------ > regex "^foo/[^x]*$-fromRegex :: String -> Pattern-fromRegex = Regex-------------------------------------------------------------------------------------- | Create a pattern which matches all items with the given version.-fromVersion :: Maybe String -> Pattern-fromVersion = Version-------------------------------------------------------------------------------------- | Specify a version, e.g.------ > "foo/*.markdown" .&&. hasVersion "pdf"-hasVersion :: String -> Pattern-hasVersion = fromVersion . Just-------------------------------------------------------------------------------------- | Match only if the identifier has no version set, e.g.------ > "foo/*.markdown" .&&. hasNoVersion-hasNoVersion :: Pattern-hasNoVersion = fromVersion Nothing-------------------------------------------------------------------------------------- | '&&' for patterns: the given identifier must match both subterms-(.&&.) :: Pattern -> Pattern -> Pattern-x .&&. y = And x y-infixr 3 .&&.-------------------------------------------------------------------------------------- | '||' for patterns: the given identifier must match any subterm-(.||.) :: Pattern -> Pattern -> Pattern-x .||. y = complement (complement x `And` complement y) -- De Morgan's law-infixr 2 .||.-------------------------------------------------------------------------------------- | Inverts a pattern, e.g.------ > complement "foo/bar.html"------ will match /anything/ except @\"foo\/bar.html\"@-complement :: Pattern -> Pattern-complement = Complement-------------------------------------------------------------------------------------- | Check if an identifier matches a pattern-matches :: Pattern -> Identifier -> Bool-matches Everything _ = True-matches (Complement p) i = not $ matches p i-matches (And x y) i = matches x i && matches y i-matches (Glob p) i = isJust $ capture (Glob p) i-matches (List l) i = i `S.member` l-matches (Regex r) i = toFilePath i =~ r-matches (Version v) i = identifierVersion i == v-------------------------------------------------------------------------------------- | Given a list of identifiers, retain only those who match the given pattern-filterMatches :: Pattern -> [Identifier] -> [Identifier]-filterMatches = filter . matches-------------------------------------------------------------------------------------- | Split a list at every possible point, generate a list of (init, tail)--- cases. The result is sorted with inits decreasing in length.-splits :: [a] -> [([a], [a])]-splits = inits &&& tails >>> uncurry zip >>> reverse-------------------------------------------------------------------------------------- | Match a glob against a pattern, generating a list of captures-capture :: Pattern -> Identifier -> Maybe [String]-capture (Glob p) i = capture' p (toFilePath i)-capture _ _ = Nothing-------------------------------------------------------------------------------------- | Internal verion of 'capture'-capture' :: [GlobComponent] -> String -> Maybe [String]-capture' [] [] = Just [] -- An empty match-capture' [] _ = Nothing -- No match-capture' (Literal l : ms) str- -- Match the literal against the string- | l `isPrefixOf` str = capture' ms $ drop (length l) str- | otherwise = Nothing-capture' (Capture : ms) str =- -- Match until the next /- let (chunk, rest) = break (== '/') str- in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]-capture' (CaptureMany : ms) str =- -- Match everything- msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]-------------------------------------------------------------------------------------- | Create an identifier from a pattern by filling in the captures with a given--- string------ Example:------ > fromCapture (fromGlob "tags/*") "foo"------ Result:------ > "tags/foo"-fromCapture :: Pattern -> String -> Identifier-fromCapture pattern = fromCaptures pattern . repeat-------------------------------------------------------------------------------------- | Create an identifier from a pattern by filling in the captures with the--- given list of strings-fromCaptures :: Pattern -> [String] -> Identifier-fromCaptures (Glob p) = fromFilePath . fromCaptures' p-fromCaptures _ = error $- "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++- "on simple globs!"-------------------------------------------------------------------------------------- | Internally used version of 'fromCaptures'-fromCaptures' :: [GlobComponent] -> [String] -> String-fromCaptures' [] _ = mempty-fromCaptures' (m : ms) [] = case m of- Literal l -> l `mappend` fromCaptures' ms []- _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "- ++ "identifier list exhausted"-fromCaptures' (m : ms) ids@(i : is) = case m of- Literal l -> l `mappend` fromCaptures' ms ids- _ -> i `mappend` fromCaptures' ms is
− src/Hakyll/Core/Item.hs
@@ -1,63 +0,0 @@------------------------------------------------------------------------------------ | An item is a combination of some content and its 'Identifier'. This way, we--- can still use the 'Identifier' to access metadata.-{-# LANGUAGE DeriveDataTypeable #-}-module Hakyll.Core.Item- ( Item (..)- , itemSetBody- , withItemBody- ) where------------------------------------------------------------------------------------import Data.Binary (Binary (..))-import Data.Foldable (Foldable (..))-import Data.Typeable (Typeable)-import Prelude hiding (foldr)------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Identifier------------------------------------------------------------------------------------data Item a = Item- { itemIdentifier :: Identifier- , itemBody :: a- } deriving (Show, Typeable)------------------------------------------------------------------------------------instance Functor Item where- fmap f (Item i x) = Item i (f x)------------------------------------------------------------------------------------instance Foldable Item where- foldr f z (Item _ x) = f x z------------------------------------------------------------------------------------instance Traversable Item where- traverse f (Item i x) = Item i <$> f x------------------------------------------------------------------------------------instance Binary a => Binary (Item a) where- put (Item i x) = put i >> put x- get = Item <$> get <*> get------------------------------------------------------------------------------------itemSetBody :: a -> Item b -> Item a-itemSetBody x (Item i _) = Item i x-------------------------------------------------------------------------------------- | Perform a compiler action on the item body. This is the same as 'traverse',--- but looks less intimidating.------ > withItemBody = traverse-withItemBody :: (a -> Compiler b) -> Item a -> Compiler (Item b)-withItemBody = traverse
− src/Hakyll/Core/Item/SomeItem.hs
@@ -1,23 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}-module Hakyll.Core.Item.SomeItem- ( SomeItem (..)- ) where------------------------------------------------------------------------------------import Data.Binary (Binary)-import Data.Typeable (Typeable)------------------------------------------------------------------------------------import Hakyll.Core.Item-import Hakyll.Core.Writable-------------------------------------------------------------------------------------- | An existential type, mostly for internal usage.-data SomeItem = forall a.- (Binary a, Typeable a, Writable a) => SomeItem (Item a)- deriving (Typeable)
− src/Hakyll/Core/Logger.hs
@@ -1,97 +0,0 @@------------------------------------------------------------------------------------ | Produce pretty, thread-safe logs-module Hakyll.Core.Logger- ( Verbosity (..)- , Logger- , new- , flush- , error- , header- , message- , debug- ) where------------------------------------------------------------------------------------import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)-import Control.Monad (forever)-import Control.Monad.Trans (MonadIO, liftIO)-import Prelude hiding (error)------------------------------------------------------------------------------------data Verbosity- = Error- | Message- | Debug- deriving (Eq, Ord, Show)-------------------------------------------------------------------------------------- | Logger structure. Very complicated.-data Logger = Logger- { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end- , loggerSync :: MVar () -- ^ Used for sync on quit- , loggerSink :: String -> IO () -- ^ Out sink- , loggerVerbosity :: Verbosity -- ^ Verbosity- }-------------------------------------------------------------------------------------- | Create a new logger-new :: Verbosity -> IO Logger-new vbty = do- logger <- Logger <$>- newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty- _ <- forkIO $ loggerThread logger- return logger- where- loggerThread logger = forever $ do- msg <- readChan $ loggerChan logger- case msg of- -- Stop: sync- Nothing -> putMVar (loggerSync logger) ()- -- Print and continue- Just m -> loggerSink logger m-------------------------------------------------------------------------------------- | Flush the logger (blocks until flushed)-flush :: Logger -> IO ()-flush logger = do- writeChan (loggerChan logger) Nothing- () <- takeMVar $ loggerSync logger- return ()------------------------------------------------------------------------------------string :: MonadIO m- => Logger -- ^ Logger- -> Verbosity -- ^ Verbosity of the string- -> String -- ^ Section name- -> m () -- ^ No result-string l v m- | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)- | otherwise = return ()------------------------------------------------------------------------------------error :: MonadIO m => Logger -> String -> m ()-error l m = string l Error $ " [ERROR] " ++ m------------------------------------------------------------------------------------header :: MonadIO m => Logger -> String -> m ()-header l = string l Message------------------------------------------------------------------------------------message :: MonadIO m => Logger -> String -> m ()-message l m = string l Message $ " " ++ m------------------------------------------------------------------------------------debug :: MonadIO m => Logger -> String -> m ()-debug l m = string l Debug $ " [DEBUG] " ++ m
− src/Hakyll/Core/Metadata.hs
@@ -1,138 +0,0 @@----------------------------------------------------------------------------------module Hakyll.Core.Metadata- ( Metadata- , lookupString- , lookupStringList-- , MonadMetadata (..)- , getMetadataField- , getMetadataField'- , makePatternDependency-- , BinaryMetadata (..)- ) where------------------------------------------------------------------------------------import Control.Arrow (second)-import Control.Monad (forM)-import Data.Binary (Binary (..), getWord8,- putWord8, Get)-import qualified Data.HashMap.Strict as HMS-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.Yaml.Extended as Yaml-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern------------------------------------------------------------------------------------type Metadata = Yaml.Object------------------------------------------------------------------------------------lookupString :: String -> Metadata -> Maybe String-lookupString key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString------------------------------------------------------------------------------------lookupStringList :: String -> Metadata -> Maybe [String]-lookupStringList key meta =- HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString------------------------------------------------------------------------------------class Monad m => MonadMetadata m where- getMetadata :: Identifier -> m Metadata- getMatches :: Pattern -> m [Identifier]-- getAllMetadata :: Pattern -> m [(Identifier, Metadata)]- getAllMetadata pattern = do- matches' <- getMatches pattern- forM matches' $ \id' -> do- metadata <- getMetadata id'- return (id', metadata)------------------------------------------------------------------------------------getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)-getMetadataField identifier key = do- metadata <- getMetadata identifier- return $ lookupString key metadata-------------------------------------------------------------------------------------- | Version of 'getMetadataField' which throws an error if the field does not--- exist.-getMetadataField' :: MonadMetadata m => Identifier -> String -> m String-getMetadataField' identifier key = do- field <- getMetadataField identifier key- case field of- Just v -> return v- Nothing -> fail $ "Hakyll.Core.Metadata.getMetadataField': " ++- "Item " ++ show identifier ++ " has no metadata field " ++ show key------------------------------------------------------------------------------------makePatternDependency :: MonadMetadata m => Pattern -> m Dependency-makePatternDependency pattern = do- matches' <- getMatches pattern- return $ PatternDependency pattern (S.fromList matches')-------------------------------------------------------------------------------------- | Newtype wrapper for serialization.-newtype BinaryMetadata = BinaryMetadata- {unBinaryMetadata :: Metadata}---instance Binary BinaryMetadata where- put (BinaryMetadata obj) = put (BinaryYaml $ Yaml.Object obj)- get = do- BinaryYaml (Yaml.Object obj) <- get- return $ BinaryMetadata obj------------------------------------------------------------------------------------newtype BinaryYaml = BinaryYaml {unBinaryYaml :: Yaml.Value}------------------------------------------------------------------------------------instance Binary BinaryYaml where- put (BinaryYaml yaml) = case yaml of- Yaml.Object obj -> do- putWord8 0- let list :: [(T.Text, BinaryYaml)]- list = map (second BinaryYaml) $ HMS.toList obj- put list-- Yaml.Array arr -> do- putWord8 1- let list = map BinaryYaml (V.toList arr) :: [BinaryYaml]- put list-- Yaml.String s -> putWord8 2 >> put s- Yaml.Number n -> putWord8 3 >> put n- Yaml.Bool b -> putWord8 4 >> put b- Yaml.Null -> putWord8 5-- get = do- tag <- getWord8- case tag of- 0 -> do- list <- get :: Get [(T.Text, BinaryYaml)]- return $ BinaryYaml $ Yaml.Object $- HMS.fromList $ map (second unBinaryYaml) list-- 1 -> do- list <- get :: Get [BinaryYaml]- return $ BinaryYaml $- Yaml.Array $ V.fromList $ map unBinaryYaml list-- 2 -> BinaryYaml . Yaml.String <$> get- 3 -> BinaryYaml . Yaml.Number <$> get- 4 -> BinaryYaml . Yaml.Bool <$> get- 5 -> return $ BinaryYaml Yaml.Null- _ -> fail "Data.Binary.get: Invalid Binary Metadata"
− src/Hakyll/Core/Provider.hs
@@ -1,43 +0,0 @@------------------------------------------------------------------------------------ | This module provides an wrapper API around the file system which does some--- caching.-module Hakyll.Core.Provider- ( -- * Constructing resource providers- Internal.Provider- , newProvider-- -- * Querying resource properties- , Internal.resourceList- , Internal.resourceExists- , Internal.resourceFilePath- , Internal.resourceModified- , Internal.resourceModificationTime-- -- * Access to raw resource content- , Internal.resourceString- , Internal.resourceLBS-- -- * Access to metadata and body content- , Internal.resourceMetadata- , Internal.resourceBody- ) where------------------------------------------------------------------------------------import qualified Hakyll.Core.Provider.Internal as Internal-import qualified Hakyll.Core.Provider.MetadataCache as Internal-import Hakyll.Core.Store (Store)-------------------------------------------------------------------------------------- | Create a resource provider-newProvider :: Store -- ^ Store to use- -> (FilePath -> IO Bool) -- ^ Should we ignore this file?- -> FilePath -- ^ Search directory- -> IO Internal.Provider -- ^ Resulting provider-newProvider store ignore directory = do- -- Delete metadata cache where necessary- p <- Internal.newProvider store ignore directory- mapM_ (Internal.resourceInvalidateMetadataCache p) $- filter (Internal.resourceModified p) $ Internal.resourceList p- return p
− src/Hakyll/Core/Provider/Internal.hs
@@ -1,202 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Hakyll.Core.Provider.Internal- ( ResourceInfo (..)- , Provider (..)- , newProvider-- , resourceList- , resourceExists-- , resourceFilePath- , resourceString- , resourceLBS-- , resourceModified- , resourceModificationTime- ) where------------------------------------------------------------------------------------import Control.DeepSeq (NFData (..), deepseq)-import Control.Monad (forM)-import Data.Binary (Binary (..))-import qualified Data.ByteString.Lazy as BL-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as S-import Data.Time (Day (..), UTCTime (..))-import Data.Typeable (Typeable)-import System.Directory (getModificationTime)-import System.FilePath (addExtension, (</>))------------------------------------------------------------------------------------#if !MIN_VERSION_directory(1,2,0)-import Data.Time (readTime)-import System.Locale (defaultTimeLocale)-import System.Time (formatCalendarTime, toCalendarTime)-#endif------------------------------------------------------------------------------------import Hakyll.Core.Identifier-import Hakyll.Core.Store (Store)-import qualified Hakyll.Core.Store as Store-import Hakyll.Core.Util.File-------------------------------------------------------------------------------------- | Because UTCTime doesn't have a Binary instance...-newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}- deriving (Eq, NFData, Ord, Show, Typeable)------------------------------------------------------------------------------------instance Binary BinaryTime where- put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =- put d >> put (toRational dt)-- get = fmap BinaryTime $ UTCTime- <$> (ModifiedJulianDay <$> get)- <*> (fromRational <$> get)------------------------------------------------------------------------------------data ResourceInfo = ResourceInfo- { resourceInfoModified :: BinaryTime- , resourceInfoMetadata :: Maybe Identifier- } deriving (Show, Typeable)------------------------------------------------------------------------------------instance Binary ResourceInfo where- put (ResourceInfo mtime meta) = put mtime >> put meta- get = ResourceInfo <$> get <*> get------------------------------------------------------------------------------------instance NFData ResourceInfo where- rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()-------------------------------------------------------------------------------------- | Responsible for retrieving and listing resources-data Provider = Provider- { -- Top of the provided directory- providerDirectory :: FilePath- , -- | A list of all files found- providerFiles :: Map Identifier ResourceInfo- , -- | A list of the files from the previous run- providerOldFiles :: Map Identifier ResourceInfo- , -- | Underlying persistent store for caching- providerStore :: Store- } deriving (Show)-------------------------------------------------------------------------------------- | Create a resource provider-newProvider :: Store -- ^ Store to use- -> (FilePath -> IO Bool) -- ^ Should we ignore this file?- -> FilePath -- ^ Search directory- -> IO Provider -- ^ Resulting provider-newProvider store ignore directory = do- list <- map fromFilePath <$> getRecursiveContents ignore directory- let universe = S.fromList list- files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do- rInfo <- getResourceInfo directory universe identifier- return (identifier, rInfo)-- -- Get the old files from the store, and then immediately replace them by- -- the new files.- oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey- oldFiles `deepseq` Store.set store oldKey files-- return $ Provider directory files oldFiles store- where- oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]-- -- Update modified if metadata is modified- maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->- let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files- in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}------------------------------------------------------------------------------------getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo-getResourceInfo directory universe identifier = do- mtime <- fileModificationTime $ directory </> toFilePath identifier- return $ ResourceInfo (BinaryTime mtime) $- if mdRsc `S.member` universe then Just mdRsc else Nothing- where- mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier------------------------------------------------------------------------------------resourceList :: Provider -> [Identifier]-resourceList = M.keys . providerFiles-------------------------------------------------------------------------------------- | Check if a given resource exists-resourceExists :: Provider -> Identifier -> Bool-resourceExists provider =- (`M.member` providerFiles provider) . setVersion Nothing------------------------------------------------------------------------------------resourceFilePath :: Provider -> Identifier -> FilePath-resourceFilePath p i = providerDirectory p </> toFilePath i-------------------------------------------------------------------------------------- | Get the raw body of a resource as string-resourceString :: Provider -> Identifier -> IO String-resourceString p i = readFile $ resourceFilePath p i-------------------------------------------------------------------------------------- | Get the raw body of a resource of a lazy bytestring-resourceLBS :: Provider -> Identifier -> IO BL.ByteString-resourceLBS p i = BL.readFile $ resourceFilePath p i-------------------------------------------------------------------------------------- | A resource is modified if it or its metadata has changed-resourceModified :: Provider -> Identifier -> Bool-resourceModified p r = case (ri, oldRi) of- (Nothing, _) -> False- (Just _, Nothing) -> True- (Just n, Just o) ->- resourceInfoModified n > resourceInfoModified o ||- resourceInfoMetadata n /= resourceInfoMetadata o- where- normal = setVersion Nothing r- ri = M.lookup normal (providerFiles p)- oldRi = M.lookup normal (providerOldFiles p)------------------------------------------------------------------------------------resourceModificationTime :: Provider -> Identifier -> UTCTime-resourceModificationTime p i =- case M.lookup (setVersion Nothing i) (providerFiles p) of- Just ri -> unBinaryTime $ resourceInfoModified ri- Nothing -> error $- "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++- "resource " ++ show i ++ " does not exist"------------------------------------------------------------------------------------fileModificationTime :: FilePath -> IO UTCTime-fileModificationTime fp = do-#if MIN_VERSION_directory(1,2,0)- getModificationTime fp-#else- ct <- toCalendarTime =<< getModificationTime fp- let str = formatCalendarTime defaultTimeLocale "%s" ct- return $ readTime defaultTimeLocale "%s" str-#endif
− src/Hakyll/Core/Provider/Metadata.hs
@@ -1,151 +0,0 @@------------------------------------------------------------------------------------ | Internal module to parse metadata-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-module Hakyll.Core.Provider.Metadata- ( loadMetadata- , parsePage-- , MetadataException (..)- ) where------------------------------------------------------------------------------------import Control.Arrow (second)-import Control.Exception (Exception, throwIO)-import Control.Monad (guard)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.List.Extended (breakWhen)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Yaml as Yaml-import Hakyll.Core.Identifier-import Hakyll.Core.Metadata-import Hakyll.Core.Provider.Internal-import System.IO as IO------------------------------------------------------------------------------------loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)-loadMetadata p identifier = do- hasHeader <- probablyHasMetadataHeader fp- (md, body) <- if hasHeader- then second Just <$> loadMetadataHeader fp- else return (mempty, Nothing)-- emd <- case mi of- Nothing -> return mempty- Just mi' -> loadMetadataFile $ resourceFilePath p mi'-- return (md <> emd, body)- where- normal = setVersion Nothing identifier- fp = resourceFilePath p identifier- mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata------------------------------------------------------------------------------------loadMetadataHeader :: FilePath -> IO (Metadata, String)-loadMetadataHeader fp = do- fileContent <- readFile fp- case parsePage fileContent of- Right x -> return x- Left err -> throwIO $ MetadataException fp err------------------------------------------------------------------------------------loadMetadataFile :: FilePath -> IO Metadata-loadMetadataFile fp = do- fileContent <- B.readFile fp- let errOrMeta = Yaml.decodeEither' fileContent- either (fail . show) return errOrMeta-------------------------------------------------------------------------------------- | Check if a file "probably" has a metadata header. The main goal of this is--- to exclude binary files (which are unlikely to start with "---").-probablyHasMetadataHeader :: FilePath -> IO Bool-probablyHasMetadataHeader fp = do- handle <- IO.openFile fp IO.ReadMode- bs <- BC.hGet handle 1024- IO.hClose handle- return $ isMetadataHeader bs- where- isMetadataHeader bs =- let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs- in BC.length pre >= 3 && BC.all (== '-') pre-------------------------------------------------------------------------------------- | Parse the page metadata and body.-splitMetadata :: String -> (Maybe String, String)-splitMetadata str0 = fromMaybe (Nothing, str0) $ do- guard $ leading >= 3- let !str1 = drop leading str0- guard $ all isNewline (take 1 str1)- let !(!meta, !content0) = breakWhen isTrailing str1- guard $ not $ null content0- let !content1 = drop (leading + 1) content0- !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1- -- Adding this newline fixes the line numbers reported by the YAML parser.- -- It's a bit ugly but it works.- return (Just ('\n' : meta), content2)- where- -- Parse the leading "---"- !leading = length $ takeWhile (== '-') str0-- -- Predicate to recognize the trailing "---" or "..."- isTrailing [] = False- isTrailing (x : xs) =- isNewline x && length (takeWhile isDash xs) == leading-- -- Characters- isNewline c = c == '\n' || c == '\r'- isDash c = c == '-' || c == '.'- isInlineSpace c = c == '\t' || c == ' '------------------------------------------------------------------------------------parseMetadata :: String -> Either Yaml.ParseException Metadata-parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack------------------------------------------------------------------------------------parsePage :: String -> Either Yaml.ParseException (Metadata, String)-parsePage fileContent = case mbMetaBlock of- Nothing -> return (mempty, content)- Just metaBlock -> case parseMetadata metaBlock of- Left err -> Left err- Right meta -> return (meta, content)- where- !(!mbMetaBlock, !content) = splitMetadata fileContent-------------------------------------------------------------------------------------- | Thrown in the IO monad if things go wrong. Provides a nice-ish error--- message.-data MetadataException = MetadataException FilePath Yaml.ParseException------------------------------------------------------------------------------------instance Exception MetadataException------------------------------------------------------------------------------------instance Show MetadataException where- show (MetadataException fp err) =- fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint-- where- hint = case err of- Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))- | yamlProblem == problem -> "\n" ++- "Hint: if the metadata value contains characters such\n" ++- "as ':' or '-', try enclosing it in quotes."- _ -> ""-- problem = "mapping values are not allowed in this context"
− src/Hakyll/Core/Provider/MetadataCache.hs
@@ -1,62 +0,0 @@----------------------------------------------------------------------------------module Hakyll.Core.Provider.MetadataCache- ( resourceMetadata- , resourceBody- , resourceInvalidateMetadataCache- ) where------------------------------------------------------------------------------------import Control.Monad (unless)-import Hakyll.Core.Identifier-import Hakyll.Core.Metadata-import Hakyll.Core.Provider.Internal-import Hakyll.Core.Provider.Metadata-import qualified Hakyll.Core.Store as Store------------------------------------------------------------------------------------resourceMetadata :: Provider -> Identifier -> IO Metadata-resourceMetadata p r- | not (resourceExists p r) = return mempty- | otherwise = do- -- TODO keep time in md cache- load p r- Store.Found (BinaryMetadata md) <- Store.get (providerStore p)- [name, toFilePath r, "metadata"]- return md------------------------------------------------------------------------------------resourceBody :: Provider -> Identifier -> IO String-resourceBody p r = do- load p r- Store.Found bd <- Store.get (providerStore p)- [name, toFilePath r, "body"]- maybe (resourceString p r) return bd------------------------------------------------------------------------------------resourceInvalidateMetadataCache :: Provider -> Identifier -> IO ()-resourceInvalidateMetadataCache p r = do- Store.delete (providerStore p) [name, toFilePath r, "metadata"]- Store.delete (providerStore p) [name, toFilePath r, "body"]------------------------------------------------------------------------------------load :: Provider -> Identifier -> IO ()-load p r = do- mmof <- Store.isMember store mdk- unless mmof $ do- (md, body) <- loadMetadata p r- Store.set store mdk (BinaryMetadata md)- Store.set store bk body- where- store = providerStore p- mdk = [name, toFilePath r, "metadata"]- bk = [name, toFilePath r, "body"]------------------------------------------------------------------------------------name :: String-name = "Hakyll.Core.Resource.Provider.MetadataCache"
− src/Hakyll/Core/Routes.hs
@@ -1,194 +0,0 @@------------------------------------------------------------------------------------ | Once a target is compiled, the user usually wants to save it to the disk.--- This is where the 'Routes' type comes in; it determines where a certain--- target should be written.------ Suppose we have an item @foo\/bar.markdown@. We can render this to--- @foo\/bar.html@ using:------ > route "foo/bar.markdown" (setExtension ".html")------ If we do not want to change the extension, we can use 'idRoute', the simplest--- route available:------ > route "foo/bar.markdown" idRoute------ That will route @foo\/bar.markdown@ to @foo\/bar.markdown@.------ Note that the extension says nothing about the content! If you set the--- extension to @.html@, it is your own responsibility to ensure that the--- content is indeed HTML.------ Finally, some special cases:------ * If there is no route for an item, this item will not be routed, so it will--- not appear in your site directory.------ * If an item matches multiple routes, the first rule will be chosen.-{-# LANGUAGE Rank2Types #-}-module Hakyll.Core.Routes- ( UsedMetadata- , Routes- , runRoutes- , idRoute- , setExtension- , matchRoute- , customRoute- , constRoute- , gsubRoute- , metadataRoute- , composeRoutes- ) where------------------------------------------------------------------------------------import System.FilePath (replaceExtension)------------------------------------------------------------------------------------import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Metadata-import Hakyll.Core.Provider-import Hakyll.Core.Util.String-------------------------------------------------------------------------------------- | When you ran a route, it's useful to know whether or not this used--- metadata. This allows us to do more granular dependency analysis.-type UsedMetadata = Bool------------------------------------------------------------------------------------data RoutesRead = RoutesRead- { routesProvider :: Provider- , routesUnderlying :: Identifier- }-------------------------------------------------------------------------------------- | Type used for a route-newtype Routes = Routes- { unRoutes :: RoutesRead -> Identifier -> IO (Maybe FilePath, UsedMetadata)- }------------------------------------------------------------------------------------instance Monoid Routes where- mempty = Routes $ \_ _ -> return (Nothing, False)- mappend (Routes f) (Routes g) = Routes $ \p id' -> do- (mfp, um) <- f p id'- case mfp of- Nothing -> g p id'- Just _ -> return (mfp, um)-------------------------------------------------------------------------------------- | Apply a route to an identifier-runRoutes :: Routes -> Provider -> Identifier- -> IO (Maybe FilePath, UsedMetadata)-runRoutes routes provider identifier =- unRoutes routes (RoutesRead provider identifier) identifier-------------------------------------------------------------------------------------- | A route that uses the identifier as filepath. For example, the target with--- ID @foo\/bar@ will be written to the file @foo\/bar@.-idRoute :: Routes-idRoute = customRoute toFilePath-------------------------------------------------------------------------------------- | Set (or replace) the extension of a route.------ Example:------ > runRoutes (setExtension "html") "foo/bar"------ Result:------ > Just "foo/bar.html"------ Example:------ > runRoutes (setExtension "html") "posts/the-art-of-trolling.markdown"------ Result:------ > Just "posts/the-art-of-trolling.html"-setExtension :: String -> Routes-setExtension extension = customRoute $- (`replaceExtension` extension) . toFilePath-------------------------------------------------------------------------------------- | Apply the route if the identifier matches the given pattern, fail--- otherwise-matchRoute :: Pattern -> Routes -> Routes-matchRoute pattern (Routes route) = Routes $ \p id' ->- if matches pattern id' then route p id' else return (Nothing, False)-------------------------------------------------------------------------------------- | Create a custom route. This should almost always be used with--- 'matchRoute'-customRoute :: (Identifier -> FilePath) -> Routes-customRoute f = Routes $ const $ \id' -> return (Just (f id'), False)-------------------------------------------------------------------------------------- | A route that always gives the same result. Obviously, you should only use--- this for a single compilation rule.-constRoute :: FilePath -> Routes-constRoute = customRoute . const-------------------------------------------------------------------------------------- | Create a gsub route------ Example:------ > runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"------ Result:------ > Just "tags/bar.xml"-gsubRoute :: String -- ^ Pattern- -> (String -> String) -- ^ Replacement- -> Routes -- ^ Resulting route-gsubRoute pattern replacement = customRoute $- replaceAll pattern replacement . toFilePath-------------------------------------------------------------------------------------- | Get access to the metadata in order to determine the route-metadataRoute :: (Metadata -> Routes) -> Routes-metadataRoute f = Routes $ \r i -> do- metadata <- resourceMetadata (routesProvider r) (routesUnderlying r)- unRoutes (f metadata) r i-------------------------------------------------------------------------------------- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent--- with @g . f@.------ Example:------ > let routes = gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml"--- > in runRoutes routes "tags/rss/bar"------ Result:------ > Just "tags/bar.xml"------ If the first route given fails, Hakyll will not apply the second route.-composeRoutes :: Routes -- ^ First route to apply- -> Routes -- ^ Second route to apply- -> Routes -- ^ Resulting route-composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do- (mfp, um) <- f p i- case mfp of- Nothing -> return (Nothing, um)- Just fp -> do- (mfp', um') <- g p (fromFilePath fp)- return (mfp', um || um')
− src/Hakyll/Core/Rules.hs
@@ -1,223 +0,0 @@------------------------------------------------------------------------------------ | This module provides a declarative DSL in which the user can specify the--- different rules used to run the compilers.------ The convention is to just list all items in the 'Rules' monad, routes and--- compilation rules.------ A typical usage example would be:------ > main = hakyll $ do--- > match "posts/*" $ do--- > route (setExtension "html")--- > compile someCompiler--- > match "css/*" $ do--- > route idRoute--- > compile compressCssCompiler-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-module Hakyll.Core.Rules- ( Rules- , match- , matchMetadata- , create- , version- , compile- , route-- -- * Advanced usage- , preprocess- , Dependency (..)- , rulesExtraDependencies- ) where------------------------------------------------------------------------------------import Control.Monad.Reader (ask, local)-import Control.Monad.State (get, modify, put)-import Control.Monad.Trans (liftIO)-import Control.Monad.Writer (censor, tell)-import Data.Maybe (fromMaybe)-import qualified Data.Set as S------------------------------------------------------------------------------------import Data.Binary (Binary)-import Data.Typeable (Typeable)------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item-import Hakyll.Core.Item.SomeItem-import Hakyll.Core.Metadata-import Hakyll.Core.Routes-import Hakyll.Core.Rules.Internal-import Hakyll.Core.Writable-------------------------------------------------------------------------------------- | Add a route-tellRoute :: Routes -> Rules ()-tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty-------------------------------------------------------------------------------------- | Add a number of compilers-tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()-tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty-------------------------------------------------------------------------------------- | Add resources-tellResources :: [Identifier] -> Rules ()-tellResources resources' = Rules $ tell $- RuleSet mempty mempty (S.fromList resources') mempty-------------------------------------------------------------------------------------- | Add a pattern-tellPattern :: Pattern -> Rules ()-tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern------------------------------------------------------------------------------------flush :: Rules ()-flush = Rules $ do- mcompiler <- rulesCompiler <$> get- case mcompiler of- Nothing -> return ()- Just compiler -> do- matches' <- rulesMatches <$> ask- version' <- rulesVersion <$> ask- route' <- fromMaybe mempty . rulesRoute <$> get-- -- The version is possibly not set correctly at this point (yet)- let ids = map (setVersion version') matches'-- {-- ids <- case fromLiteral pattern of- Just id' -> return [setVersion version' id']- Nothing -> do- ids <- unRules $ getMatches pattern- unRules $ tellResources ids- return $ map (setVersion version') ids- -}-- -- Create a fast pattern for routing that matches exactly the- -- compilers created in the block given to match- let fastPattern = fromList ids-- -- Write out the compilers and routes- unRules $ tellRoute $ matchRoute fastPattern route'- unRules $ tellCompilers $ [(id', compiler) | id' <- ids]-- put $ emptyRulesState------------------------------------------------------------------------------------matchInternal :: Pattern -> Rules [Identifier] -> Rules () -> Rules ()-matchInternal pattern getIDs rules = do- tellPattern pattern- flush- ids <- getIDs- tellResources ids- Rules $ local (setMatches ids) $ unRules $ rules >> flush- where- setMatches ids env = env {rulesMatches = ids}-----------------------------------------------------------------------------------match :: Pattern -> Rules () -> Rules ()-match pattern = matchInternal pattern $ getMatches pattern------------------------------------------------------------------------------------matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules ()-matchMetadata pattern metadataPred = matchInternal pattern $- map fst . filter (metadataPred . snd) <$> getAllMetadata pattern------------------------------------------------------------------------------------create :: [Identifier] -> Rules () -> Rules ()-create ids rules = do- flush- -- TODO Maybe check if the resources exist and call tellResources on that- Rules $ local setMatches $ unRules $ rules >> flush- where- setMatches env = env {rulesMatches = ids}------------------------------------------------------------------------------------version :: String -> Rules () -> Rules ()-version v rules = do- flush- Rules $ local setVersion' $ unRules $ rules >> flush- where- setVersion' env = env {rulesVersion = Just v}-------------------------------------------------------------------------------------- | Add a compilation rule to the rules.------ This instructs all resources to be compiled using the given compiler.-compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules ()-compile compiler = Rules $ modify $ \s ->- s {rulesCompiler = Just (fmap SomeItem compiler)}-------------------------------------------------------------------------------------- | Add a route.------ This adds a route for all items matching the current pattern.-route :: Routes -> Rules ()-route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'}-------------------------------------------------------------------------------------- | Execute an 'IO' action immediately while the rules are being evaluated.--- This should be avoided if possible, but occasionally comes in useful.-preprocess :: IO a -> Rules a-preprocess = Rules . liftIO-------------------------------------------------------------------------------------- | Advanced usage: add extra dependencies to compilers. Basically this is--- needed when you're doing unsafe tricky stuff in the rules monad, but you--- still want correct builds.------ A useful utility for this purpose is 'makePatternDependency'.-rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a-rulesExtraDependencies deps rules =- -- Note that we add the dependencies seemingly twice here. However, this is- -- done so that 'rulesExtraDependencies' works both if we have something- -- like:- --- -- > match "*.css" $ rulesExtraDependencies [foo] $ ...- --- -- and something like:- --- -- > rulesExtraDependencies [foo] $ match "*.css" $ ...- --- -- (1) takes care of the latter and (2) of the former.- Rules $ censor fixRuleSet $ do- x <- unRules rules- fixCompiler- return x- where- -- (1) Adds the dependencies to the compilers we are yet to create- fixCompiler = modify $ \s -> case rulesCompiler s of- Nothing -> s- Just c -> s- { rulesCompiler = Just $ compilerTellDependencies deps >> c- }-- -- (2) Adds the dependencies to the compilers that are already in the ruleset- fixRuleSet ruleSet = ruleSet- { rulesCompilers =- [ (i, compilerTellDependencies deps >> c)- | (i, c) <- rulesCompilers ruleSet- ]- }
− src/Hakyll/Core/Rules/Internal.hs
@@ -1,109 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE Rank2Types #-}-module Hakyll.Core.Rules.Internal- ( RulesRead (..)- , RuleSet (..)- , RulesState (..)- , emptyRulesState- , Rules (..)- , runRules- ) where------------------------------------------------------------------------------------import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWST, runRWST)-import Control.Monad.Trans (liftIO)-import qualified Data.Map as M-import Data.Set (Set)------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item.SomeItem-import Hakyll.Core.Metadata-import Hakyll.Core.Provider-import Hakyll.Core.Routes------------------------------------------------------------------------------------data RulesRead = RulesRead- { rulesProvider :: Provider- , rulesMatches :: [Identifier]- , rulesVersion :: Maybe String- }------------------------------------------------------------------------------------data RuleSet = RuleSet- { -- | Accumulated routes- rulesRoutes :: Routes- , -- | Accumulated compilers- rulesCompilers :: [(Identifier, Compiler SomeItem)]- , -- | A set of the actually used files- rulesResources :: Set Identifier- , -- | A pattern we can use to check if a file *would* be used. This is- -- needed for the preview server.- rulesPattern :: Pattern- }------------------------------------------------------------------------------------instance Monoid RuleSet where- mempty = RuleSet mempty mempty mempty mempty- mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =- RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)------------------------------------------------------------------------------------data RulesState = RulesState- { rulesRoute :: Maybe Routes- , rulesCompiler :: Maybe (Compiler SomeItem)- }------------------------------------------------------------------------------------emptyRulesState :: RulesState-emptyRulesState = RulesState Nothing Nothing-------------------------------------------------------------------------------------- | The monad used to compose rules-newtype Rules a = Rules- { unRules :: RWST RulesRead RuleSet RulesState IO a- } deriving (Monad, Functor, Applicative)------------------------------------------------------------------------------------instance MonadMetadata Rules where- getMetadata identifier = Rules $ do- provider <- rulesProvider <$> ask- liftIO $ resourceMetadata provider identifier-- getMatches pattern = Rules $ do- provider <- rulesProvider <$> ask- return $ filterMatches pattern $ resourceList provider-------------------------------------------------------------------------------------- | Run a Rules monad, resulting in a 'RuleSet'-runRules :: Rules a -> Provider -> IO RuleSet-runRules rules provider = do- (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState-- -- Ensure compiler uniqueness- let ruleSet' = ruleSet- { rulesCompilers = M.toList $- M.fromListWith (flip const) (rulesCompilers ruleSet)- }-- return ruleSet'- where- env = RulesRead- { rulesProvider = provider- , rulesMatches = []- , rulesVersion = Nothing- }
− src/Hakyll/Core/Runtime.hs
@@ -1,276 +0,0 @@----------------------------------------------------------------------------------module Hakyll.Core.Runtime- ( run- ) where------------------------------------------------------------------------------------import Control.Monad (unless)-import Control.Monad.Except (ExceptT, runExceptT, throwError)-import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWST, runRWST)-import Control.Monad.State (get, modify)-import Control.Monad.Trans (liftIO)-import Data.List (intercalate)-import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S-import System.Exit (ExitCode (..))-import System.FilePath ((</>))------------------------------------------------------------------------------------import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Compiler.Require-import Hakyll.Core.Configuration-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Core.Item.SomeItem-import Hakyll.Core.Logger (Logger)-import qualified Hakyll.Core.Logger as Logger-import Hakyll.Core.Provider-import Hakyll.Core.Routes-import Hakyll.Core.Rules.Internal-import Hakyll.Core.Store (Store)-import qualified Hakyll.Core.Store as Store-import Hakyll.Core.Util.File-import Hakyll.Core.Writable------------------------------------------------------------------------------------run :: Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)-run config logger rules = do- -- Initialization- Logger.header logger "Initialising..."- Logger.message logger "Creating store..."- store <- Store.new (inMemoryCache config) $ storeDirectory config- Logger.message logger "Creating provider..."- provider <- newProvider store (shouldIgnoreFile config) $- providerDirectory config- Logger.message logger "Running rules..."- ruleSet <- runRules rules provider-- -- Get old facts- mOldFacts <- Store.get store factsKey- let (oldFacts) = case mOldFacts of Store.Found f -> f- _ -> mempty-- -- Build runtime read/state- let compilers = rulesCompilers ruleSet- read' = RuntimeRead- { runtimeConfiguration = config- , runtimeLogger = logger- , runtimeProvider = provider- , runtimeStore = store- , runtimeRoutes = rulesRoutes ruleSet- , runtimeUniverse = M.fromList compilers- }- state = RuntimeState- { runtimeDone = S.empty- , runtimeSnapshots = S.empty- , runtimeTodo = M.empty- , runtimeFacts = oldFacts- }-- -- Run the program and fetch the resulting state- result <- runExceptT $ runRWST build read' state- case result of- Left e -> do- Logger.error logger e- Logger.flush logger- return (ExitFailure 1, ruleSet)-- Right (_, s, _) -> do- Store.set store factsKey $ runtimeFacts s-- Logger.debug logger "Removing tmp directory..."- removeDirectory $ tmpDirectory config-- Logger.flush logger- return (ExitSuccess, ruleSet)- where- factsKey = ["Hakyll.Core.Runtime.run", "facts"]------------------------------------------------------------------------------------data RuntimeRead = RuntimeRead- { runtimeConfiguration :: Configuration- , runtimeLogger :: Logger- , runtimeProvider :: Provider- , runtimeStore :: Store- , runtimeRoutes :: Routes- , runtimeUniverse :: Map Identifier (Compiler SomeItem)- }------------------------------------------------------------------------------------data RuntimeState = RuntimeState- { runtimeDone :: Set Identifier- , runtimeSnapshots :: Set (Identifier, Snapshot)- , runtimeTodo :: Map Identifier (Compiler SomeItem)- , runtimeFacts :: DependencyFacts- }------------------------------------------------------------------------------------type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a------------------------------------------------------------------------------------build :: Runtime ()-build = do- logger <- runtimeLogger <$> ask- Logger.header logger "Checking for out-of-date items"- scheduleOutOfDate- Logger.header logger "Compiling"- pickAndChase- Logger.header logger "Success"------------------------------------------------------------------------------------scheduleOutOfDate :: Runtime ()-scheduleOutOfDate = do- logger <- runtimeLogger <$> ask- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- facts <- runtimeFacts <$> get- todo <- runtimeTodo <$> get-- let identifiers = M.keys universe- modified = S.fromList $ flip filter identifiers $- resourceModified provider-- let (ood, facts', msgs) = outOfDate identifiers modified facts- todo' = M.filterWithKey- (\id' _ -> id' `S.member` ood) universe-- -- Print messages- mapM_ (Logger.debug logger) msgs-- -- Update facts and todo items- modify $ \s -> s- { runtimeDone = runtimeDone s `S.union`- (S.fromList identifiers `S.difference` ood)- , runtimeTodo = todo `M.union` todo'- , runtimeFacts = facts'- }------------------------------------------------------------------------------------pickAndChase :: Runtime ()-pickAndChase = do- todo <- runtimeTodo <$> get- case M.minViewWithKey todo of- Nothing -> return ()- Just ((id', _), _) -> do- chase [] id'- pickAndChase------------------------------------------------------------------------------------chase :: [Identifier] -> Identifier -> Runtime ()-chase trail id'- | id' `elem` trail = throwError $ "Hakyll.Core.Runtime.chase: " ++- "Dependency cycle detected: " ++ intercalate " depends on "- (map show $ dropWhile (/= id') (reverse trail) ++ [id'])- | otherwise = do- logger <- runtimeLogger <$> ask- todo <- runtimeTodo <$> get- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- routes <- runtimeRoutes <$> ask- store <- runtimeStore <$> ask- config <- runtimeConfiguration <$> ask- Logger.debug logger $ "Processing " ++ show id'-- let compiler = todo M.! id'- read' = CompilerRead- { compilerConfig = config- , compilerUnderlying = id'- , compilerProvider = provider- , compilerUniverse = M.keysSet universe- , compilerRoutes = routes- , compilerStore = store- , compilerLogger = logger- }-- result <- liftIO $ runCompiler compiler read'- case result of- -- Rethrow error- CompilerError [] -> throwError- "Compiler failed but no info given, try running with -v?"- CompilerError es -> throwError $ intercalate "; " es-- -- Signal that a snapshot was saved ->- CompilerSnapshot snapshot c -> do- -- Update info. The next 'chase' will pick us again at some- -- point so we can continue then.- modify $ \s -> s- { runtimeSnapshots =- S.insert (id', snapshot) (runtimeSnapshots s)- , runtimeTodo = M.insert id' c (runtimeTodo s)- }-- -- Huge success- CompilerDone (SomeItem item) cwrite -> do- -- Print some info- let facts = compilerDependencies cwrite- cacheHits- | compilerCacheHits cwrite <= 0 = "updated"- | otherwise = "cached "- Logger.message logger $ cacheHits ++ " " ++ show id'-- -- Sanity check- unless (itemIdentifier item == id') $ throwError $- "The compiler yielded an Item with Identifier " ++- show (itemIdentifier item) ++ ", but we were expecting " ++- "an Item with Identifier " ++ show id' ++ " " ++- "(you probably want to call makeItem to solve this problem)"-- -- Write if necessary- (mroute, _) <- liftIO $ runRoutes routes provider id'- case mroute of- Nothing -> return ()- Just route -> do- let path = destinationDirectory config </> route- liftIO $ makeDirectories path- liftIO $ write path item- Logger.debug logger $ "Routed to " ++ path-- -- Save! (For load)- liftIO $ save store item-- -- Update state- modify $ \s -> s- { runtimeDone = S.insert id' (runtimeDone s)- , runtimeTodo = M.delete id' (runtimeTodo s)- , runtimeFacts = M.insert id' facts (runtimeFacts s)- }-- -- Try something else first- CompilerRequire dep c -> do- -- Update the compiler so we don't execute it twice- let (depId, depSnapshot) = dep- done <- runtimeDone <$> get- snapshots <- runtimeSnapshots <$> get-- -- Done if we either completed the entire item (runtimeDone) or- -- if we previously saved the snapshot (runtimeSnapshots).- let depDone =- depId `S.member` done ||- (depId, depSnapshot) `S.member` snapshots-- modify $ \s -> s- { runtimeTodo = M.insert id'- (if depDone then c else compilerResult result)- (runtimeTodo s)- }-- -- If the required item is already compiled, continue, or, start- -- chasing that- Logger.debug logger $ "Require " ++ show depId ++- " (snapshot " ++ depSnapshot ++ "): " ++- (if depDone then "OK" else "chasing")- if depDone then chase trail id' else chase (id' : trail) depId
− src/Hakyll/Core/Store.hs
@@ -1,197 +0,0 @@------------------------------------------------------------------------------------ | A store for storing and retreiving items-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Hakyll.Core.Store- ( Store- , Result (..)- , toMaybe- , new- , set- , get- , isMember- , delete- , hash- ) where------------------------------------------------------------------------------------import Control.Exception (IOException, handle)-import qualified Crypto.Hash.MD5 as MD5-import Data.Binary (Binary, decode, encodeFile)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Cache.LRU.IO as Lru-import Data.List (intercalate)-import Data.Maybe (isJust)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable (TypeRep, Typeable, cast, typeOf)-import System.Directory (createDirectoryIfMissing)-import System.Directory (doesFileExist, removeFile)-import System.FilePath ((</>))-import System.IO (IOMode (..), hClose, openFile)-import Text.Printf (printf)-------------------------------------------------------------------------------------- | Simple wrapper type-data Box = forall a. Typeable a => Box a------------------------------------------------------------------------------------data Store = Store- { -- | All items are stored on the filesystem- storeDirectory :: FilePath- , -- | Optionally, items are also kept in-memory- storeMap :: Maybe (Lru.AtomicLRU FilePath Box)- }------------------------------------------------------------------------------------instance Show Store where- show _ = "<Store>"-------------------------------------------------------------------------------------- | Result of a store query-data Result a- = Found a -- ^ Found, result- | NotFound -- ^ Not found- | WrongType TypeRep TypeRep -- ^ Expected, true type- deriving (Show, Eq)-------------------------------------------------------------------------------------- | Convert result to 'Maybe'-toMaybe :: Result a -> Maybe a-toMaybe (Found x) = Just x-toMaybe _ = Nothing-------------------------------------------------------------------------------------- | Initialize the store-new :: Bool -- ^ Use in-memory caching- -> FilePath -- ^ Directory to use for hard disk storage- -> IO Store -- ^ Store-new inMemory directory = do- createDirectoryIfMissing True directory- ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing- return Store- { storeDirectory = directory- , storeMap = ref- }- where- csize = Just 500-------------------------------------------------------------------------------------- | Auxiliary: add an item to the in-memory cache-cacheInsert :: Typeable a => Store -> String -> a -> IO ()-cacheInsert (Store _ Nothing) _ _ = return ()-cacheInsert (Store _ (Just lru)) key x =- Lru.insert key (Box x) lru-------------------------------------------------------------------------------------- | Auxiliary: get an item from the in-memory cache-cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)-cacheLookup (Store _ Nothing) _ = return NotFound-cacheLookup (Store _ (Just lru)) key = do- res <- Lru.lookup key lru- return $ case res of- Nothing -> NotFound- Just (Box x) -> case cast x of- Just x' -> Found x'- Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)------------------------------------------------------------------------------------cacheIsMember :: Store -> String -> IO Bool-cacheIsMember (Store _ Nothing) _ = return False-cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru-------------------------------------------------------------------------------------- | Auxiliary: delete an item from the in-memory cache-cacheDelete :: Store -> String -> IO ()-cacheDelete (Store _ Nothing) _ = return ()-cacheDelete (Store _ (Just lru)) key = do- _ <- Lru.delete key lru- return ()-------------------------------------------------------------------------------------- | Store an item-set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()-set store identifier value = do- encodeFile (storeDirectory store </> key) value- cacheInsert store key value- where- key = hash identifier-------------------------------------------------------------------------------------- | Load an item-get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)-get store identifier = do- -- First check the in-memory map- ref <- cacheLookup store key- case ref of- -- Not found in the map, try the filesystem- NotFound -> do- exists <- doesFileExist path- if not exists- -- Not found in the filesystem either- then return NotFound- -- Found in the filesystem- else do- v <- decodeClose- cacheInsert store key v- return $ Found v- -- Found in the in-memory map (or wrong type), just return- s -> return s- where- key = hash identifier- path = storeDirectory store </> key-- -- 'decodeFile' from Data.Binary which closes the file ASAP- decodeClose = do- h <- openFile path ReadMode- lbs <- BL.hGetContents h- BL.length lbs `seq` hClose h- return $ decode lbs-------------------------------------------------------------------------------------- | Strict function-isMember :: Store -> [String] -> IO Bool-isMember store identifier = do- inCache <- cacheIsMember store key- if inCache then return True else doesFileExist path- where- key = hash identifier- path = storeDirectory store </> key-------------------------------------------------------------------------------------- | Delete an item-delete :: Store -> [String] -> IO ()-delete store identifier = do- cacheDelete store key- deleteFile $ storeDirectory store </> key- where- key = hash identifier-------------------------------------------------------------------------------------- | Delete a file unless it doesn't exist...-deleteFile :: FilePath -> IO ()-deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile-------------------------------------------------------------------------------------- | Mostly meant for internal usage-hash :: [String] -> String-hash = concatMap (printf "%02x") . B.unpack .- MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"
− src/Hakyll/Core/UnixFilter.hs
@@ -1,159 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- | A Compiler that supports unix filters.-module Hakyll.Core.UnixFilter- ( unixFilter- , unixFilterLBS- ) where------------------------------------------------------------------------------------import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.DeepSeq (deepseq)-import Control.Monad (forM_)-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as LB-import Data.IORef (newIORef, readIORef, writeIORef)-import System.Exit (ExitCode (..))-import System.IO (Handle, hClose, hFlush, hGetContents,- hPutStr, hSetEncoding, localeEncoding)-import System.Process-----------------------------------------------------------------------------------import Hakyll.Core.Compiler-------------------------------------------------------------------------------------- | Use a unix filter as compiler. For example, we could use the 'rev' program--- as a compiler.------ > rev :: Compiler (Item String)--- > rev = getResourceString >>= withItemBody (unixFilter "rev" [])------ A more realistic example: one can use this to call, for example, the sass--- compiler on CSS files. More information about sass can be found here:------ <http://sass-lang.com/>------ The code is fairly straightforward, given that we use @.scss@ for sass:------ > match "style.scss" $ do--- > route $ setExtension "css"--- > compile $ getResourceString >>=--- > withItemBody (unixFilter "sass" ["-s", "--scss"]) >>=--- > return . fmap compressCss-unixFilter :: String -- ^ Program name- -> [String] -- ^ Program args- -> String -- ^ Program input- -> Compiler String -- ^ Program output-unixFilter = unixFilterWith writer reader- where- writer handle input = do- hSetEncoding handle localeEncoding- hPutStr handle input- reader handle = do- hSetEncoding handle localeEncoding- out <- hGetContents handle- deepseq out (return out)-------------------------------------------------------------------------------------- | Variant of 'unixFilter' that should be used for binary files------ > match "music.wav" $ do--- > route $ setExtension "ogg"--- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"])-unixFilterLBS :: String -- ^ Program name- -> [String] -- ^ Program args- -> ByteString -- ^ Program input- -> Compiler ByteString -- ^ Program output-unixFilterLBS = unixFilterWith LB.hPutStr $ \handle -> do- out <- LB.hGetContents handle- LB.length out `seq` return out-------------------------------------------------------------------------------------- | Overloaded compiler-unixFilterWith :: Monoid o- => (Handle -> i -> IO ()) -- ^ Writer- -> (Handle -> IO o) -- ^ Reader- -> String -- ^ Program name- -> [String] -- ^ Program args- -> i -- ^ Program input- -> Compiler o -- ^ Program output-unixFilterWith writer reader programName args input = do- debugCompiler ("Executing external program " ++ programName)- (output, err, exitCode) <- unsafeCompiler $- unixFilterIO writer reader programName args input- forM_ (lines err) debugCompiler- case exitCode of- ExitSuccess -> return output- ExitFailure e -> fail $- "Hakyll.Core.UnixFilter.unixFilterWith: " ++- unwords (programName : args) ++ " gave exit code " ++ show e-------------------------------------------------------------------------------------- | Internally used function-unixFilterIO :: Monoid o- => (Handle -> i -> IO ())- -> (Handle -> IO o)- -> String- -> [String]- -> i- -> IO (o, String, ExitCode)-unixFilterIO writer reader programName args input = do- -- The problem on Windows is that `proc` is unable to execute- -- batch stubs (eg. anything created using 'gem install ...') even if its in- -- `$PATH`. A solution to this issue is to execute the batch file explicitly- -- using `cmd /c batchfile` but there is no rational way to know where said- -- batchfile is on the system. Hence, we detect windows using the- -- CPP and instead of using `proc` to create the process, use `shell`- -- which will be able to execute everything `proc` can- -- as well as batch files.-#ifdef mingw32_HOST_OS- let pr = shell $ unwords (programName : args)-#else- let pr = proc programName args-#endif-- (Just inh, Just outh, Just errh, pid) <-- createProcess pr- { std_in = CreatePipe- , std_out = CreatePipe- , std_err = CreatePipe- }-- -- Create boxes- lock <- newEmptyMVar- outRef <- newIORef mempty- errRef <- newIORef ""-- -- Write the input to the child pipe- _ <- forkIO $ writer inh input >> hFlush inh >> hClose inh-- -- Read from stdout- _ <- forkIO $ do- out <- reader outh- hClose outh- writeIORef outRef out- putMVar lock ()-- -- Read from stderr- _ <- forkIO $ do- hSetEncoding errh localeEncoding- err <- hGetContents errh- _ <- deepseq err (return err)- hClose errh- writeIORef errRef err- putMVar lock ()-- -- Get exit code & return- takeMVar lock- takeMVar lock- exitCode <- waitForProcess pid- out <- readIORef outRef- err <- readIORef errRef- return (out, err, exitCode)
− src/Hakyll/Core/Util/File.hs
@@ -1,56 +0,0 @@------------------------------------------------------------------------------------ | A module containing various file utility functions-module Hakyll.Core.Util.File- ( makeDirectories- , getRecursiveContents- , removeDirectory- ) where------------------------------------------------------------------------------------import Control.Monad (filterM, forM, when)-import System.Directory (createDirectoryIfMissing,- doesDirectoryExist, getDirectoryContents,- removeDirectoryRecursive)-import System.FilePath (takeDirectory, (</>))-------------------------------------------------------------------------------------- | Given a path to a file, try to make the path writable by making--- all directories on the path.-makeDirectories :: FilePath -> IO ()-makeDirectories = createDirectoryIfMissing True . takeDirectory-------------------------------------------------------------------------------------- | Get all contents of a directory.-getRecursiveContents :: (FilePath -> IO Bool) -- ^ Ignore this file/directory- -> FilePath -- ^ Directory to search- -> IO [FilePath] -- ^ List of files found-getRecursiveContents ignore top = go ""- where- isProper x- | x `elem` [".", ".."] = return False- | otherwise = not <$> ignore x-- go dir = do- dirExists <- doesDirectoryExist (top </> dir)- if not dirExists- then return []- else do- names <- filterM isProper =<< getDirectoryContents (top </> dir)- paths <- forM names $ \name -> do- let rel = dir </> name- isDirectory <- doesDirectoryExist (top </> rel)- if isDirectory- then go rel- else return [rel]-- return $ concat paths------------------------------------------------------------------------------------removeDirectory :: FilePath -> IO ()-removeDirectory fp = do- e <- doesDirectoryExist fp- when e $ removeDirectoryRecursive fp
− src/Hakyll/Core/Util/Parser.hs
@@ -1,25 +0,0 @@------------------------------------------------------------------------------------ | Parser utilities-module Hakyll.Core.Util.Parser- ( metadataKey- , reservedKeys- ) where------------------------------------------------------------------------------------import Control.Applicative ((<|>))-import Control.Monad (mzero)-import qualified Text.Parsec as P-import Text.Parsec.String (Parser)------------------------------------------------------------------------------------metadataKey :: Parser String-metadataKey = do- i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf "_-.")- if i `elem` reservedKeys then mzero else return i------------------------------------------------------------------------------------reservedKeys :: [String]-reservedKeys = ["if", "else", "endif", "for", "sep", "endfor", "partial"]
− src/Hakyll/Core/Util/String.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------ | Miscellaneous string manipulation functions.-module Hakyll.Core.Util.String- ( trim- , replaceAll- , splitAll- , needlePrefix- ) where------------------------------------------------------------------------------------import Data.Char (isSpace)-import Data.List (isPrefixOf)-import Data.Maybe (listToMaybe)-import Text.Regex.TDFA ((=~~))-------------------------------------------------------------------------------------- | Trim a string (drop spaces, tabs and newlines at both sides).-trim :: String -> String-trim = reverse . trim' . reverse . trim'- where- trim' = dropWhile isSpace-------------------------------------------------------------------------------------- | A simple (but inefficient) regex replace funcion-replaceAll :: String -- ^ Pattern- -> (String -> String) -- ^ Replacement (called on capture)- -> String -- ^ Source string- -> String -- ^ Result-replaceAll pattern f source = replaceAll' source- where- replaceAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> src- Just (o, l) ->- let (before, tmp) = splitAt o src- (capture, after) = splitAt l tmp- in before ++ f capture ++ replaceAll' after-------------------------------------------------------------------------------------- | A simple regex split function. The resulting list will contain no empty--- strings.-splitAll :: String -- ^ Pattern- -> String -- ^ String to split- -> [String] -- ^ Result-splitAll pattern = filter (not . null) . splitAll'- where- splitAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> [src]- Just (o, l) ->- let (before, tmp) = splitAt o src- in before : splitAll' (drop l tmp)--------------------------------------------------------------------------------------- | Find the first instance of needle (must be non-empty) in haystack. We--- return the prefix of haystack before needle is matched.------ Examples:------ > needlePrefix "cd" "abcde" = "ab"------ > needlePrefix "ab" "abc" = ""------ > needlePrefix "ab" "xxab" = "xx"------ > needlePrefix "a" "xx" = "xx"-needlePrefix :: String -> String -> Maybe String-needlePrefix needle haystack = go [] haystack- where- go _ [] = Nothing- go acc xss@(x:xs)- | needle `isPrefixOf` xss = Just $ reverse acc- | otherwise = go (x : acc) xs
− src/Hakyll/Core/Writable.hs
@@ -1,56 +0,0 @@------------------------------------------------------------------------------------ | Describes writable items; items that can be saved to the disk-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Hakyll.Core.Writable- ( Writable (..)- ) where------------------------------------------------------------------------------------import qualified Data.ByteString as SB-import qualified Data.ByteString.Lazy as LB-import Data.Word (Word8)-import Text.Blaze.Html (Html)-import Text.Blaze.Html.Renderer.String (renderHtml)------------------------------------------------------------------------------------import Hakyll.Core.Item-------------------------------------------------------------------------------------- | Describes an item that can be saved to the disk-class Writable a where- -- | Save an item to the given filepath- write :: FilePath -> Item a -> IO ()------------------------------------------------------------------------------------instance Writable () where- write _ _ = return ()------------------------------------------------------------------------------------instance Writable [Char] where- write p = writeFile p . itemBody------------------------------------------------------------------------------------instance Writable SB.ByteString where- write p = SB.writeFile p . itemBody------------------------------------------------------------------------------------instance Writable LB.ByteString where- write p = LB.writeFile p . itemBody------------------------------------------------------------------------------------instance Writable [Word8] where- write p = write p . fmap SB.pack------------------------------------------------------------------------------------instance Writable Html where- write p = write p . fmap renderHtml
− src/Hakyll/Init.hs
@@ -1,96 +0,0 @@----------------------------------------------------------------------------------module Main- ( main- ) where------------------------------------------------------------------------------------import Control.Arrow (first)-import Control.Monad (forM_)-import Data.Char (isAlphaNum, isNumber)-import Data.List (foldl')-import Data.List (intercalate, isPrefixOf)-import Data.Version (Version (..))-import System.Directory (canonicalizePath, copyFile)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure)-import System.FilePath (splitDirectories, (</>))------------------------------------------------------------------------------------import Hakyll.Core.Util.File-import Paths_hakyll------------------------------------------------------------------------------------main :: IO ()-main = do- progName <- getProgName- args <- getArgs- srcDir <- getDataFileName "example"- files <- getRecursiveContents (const $ return False) srcDir-- case args of- -- When the argument begins with hyphens, it's more likely that the user- -- intends to attempt some arguments like ("--help", "-h", "--version", etc.)- -- rather than create directory with that name.- -- If dstDir begins with hyphens, the guard will prevent it from creating- -- directory with that name so we can fall to the second alternative- -- which prints a usage info for user.- [dstDir] | not ("-" `isPrefixOf` dstDir) -> do- forM_ files $ \file -> do- let dst = dstDir </> file- src = srcDir </> file- putStrLn $ "Creating " ++ dst- makeDirectories dst- copyFile src dst-- name <- makeName dstDir- let cabalPath = dstDir </> name ++ ".cabal"- putStrLn $ "Creating " ++ cabalPath- createCabal cabalPath name- _ -> do- putStrLn $ "Usage: " ++ progName ++ " <directory>"- exitFailure---- | Figure out a good cabal package name from the given (existing) directory--- name-makeName :: FilePath -> IO String-makeName dstDir = do- canonical <- canonicalizePath dstDir- return $ case safeLast (splitDirectories canonical) of- Nothing -> fallbackName- Just "/" -> fallbackName- Just x -> repair (fallbackName ++) id x- where- -- Package name repair code comes from- -- cabal-install.Distribution.Client.Init.Heuristics- repair invalid valid x = case dropWhile (not . isAlphaNum) x of- "" -> repairComponent ""- x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'- in c ++ repairRest r- where repairComponent c | all isNumber c = invalid c- | otherwise = valid c- repairRest = repair id ('-' :)- fallbackName = "site"-- safeLast = foldl' (\_ x -> Just x) Nothing--createCabal :: FilePath -> String -> IO ()-createCabal path name = do- writeFile path $ unlines [- "name: " ++ name- , "version: 0.1.0.0"- , "build-type: Simple"- , "cabal-version: >= 1.10"- , ""- , "executable site"- , " main-is: site.hs"- , " build-depends: base == 4.*"- , " , hakyll == " ++ version' ++ ".*"- , " ghc-options: -threaded"- , " default-language: Haskell2010"- ]- where- -- Major hakyll version- version' = intercalate "." . take 2 . map show $ versionBranch version
− src/Hakyll/Main.hs
@@ -1,128 +0,0 @@------------------------------------------------------------------------------------ | Module providing the main hakyll function and command-line argument parsing-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Hakyll.Main- ( hakyll- , hakyllWith- , hakyllWithExitCode- ) where------------------------------------------------------------------------------------import System.Console.CmdArgs-import qualified System.Console.CmdArgs.Explicit as CA-import System.Environment (getProgName)-import System.IO.Unsafe (unsafePerformIO)-import System.Exit (ExitCode(ExitSuccess), exitWith)-----------------------------------------------------------------------------------import qualified Hakyll.Check as Check-import qualified Hakyll.Commands as Commands-import qualified Hakyll.Core.Configuration as Config-import qualified Hakyll.Core.Logger as Logger-import Hakyll.Core.Rules-------------------------------------------------------------------------------------- | This usualy is the function with which the user runs the hakyll compiler-hakyll :: Rules a -> IO ()-hakyll = hakyllWith Config.defaultConfiguration------------------------------------------------------------------------------------- | A variant of 'hakyll' which allows the user to specify a custom--- configuration-hakyllWith :: Config.Configuration -> Rules a -> IO ()-hakyllWith conf rules = hakyllWithExitCode conf rules >>= exitWith--hakyllWithExitCode :: Config.Configuration -> Rules a -> IO ExitCode-hakyllWithExitCode conf rules = do- args' <- cmdArgs (hakyllArgs conf)-- let verbosity' = if verbose args' then Logger.Debug else Logger.Message- check' =- if internal_links args' then Check.InternalLinks else Check.All-- logger <- Logger.new verbosity'- case args' of- Build _ -> Commands.build conf logger rules- Check _ _ -> Commands.check conf logger check' >> ok- Clean _ -> Commands.clean conf logger >> ok- Deploy _ -> Commands.deploy conf- Help _ -> showHelp >> ok- Preview _ p -> Commands.preview conf logger rules p >> ok- Rebuild _ -> Commands.rebuild conf logger rules- Server _ _ _ -> Commands.server conf logger (host args') (port args') >> ok- Watch _ _ p s -> Commands.watch conf logger (host args') p (not s) rules >> ok- where- ok = return ExitSuccess-------------------------------------------------------------------------------------- | Show usage information.-showHelp :: IO ()-showHelp = print $ CA.helpText [] CA.HelpFormatOne $ cmdArgsMode (hakyllArgs Config.defaultConfiguration)------------------------------------------------------------------------------------data HakyllArgs- = Build {verbose :: Bool}- | Check {verbose :: Bool, internal_links :: Bool}- | Clean {verbose :: Bool}- | Deploy {verbose :: Bool}- | Help {verbose :: Bool}- | Preview {verbose :: Bool, port :: Int}- | Rebuild {verbose :: Bool}- | Server {verbose :: Bool, host :: String, port :: Int}- | Watch {verbose :: Bool, host :: String, port :: Int, no_server :: Bool }- deriving (Data, Typeable, Show)------------------------------------------------------------------------------------hakyllArgs :: Config.Configuration -> HakyllArgs-hakyllArgs conf = modes- [ (Build $ verboseFlag def) &= help "Generate the site"- , (Check (verboseFlag def) (False &= help "Check internal links only")) &=- help "Validate the site output"- , (Clean $ verboseFlag def) &= help "Clean up and remove cache"- , (Deploy $ verboseFlag def) &= help "Upload/deploy your site"- , (Help $ verboseFlag def) &= help "Show this message" &= auto- , (Preview (verboseFlag def) (portFlag defaultPort)) &=- help "[Deprecated] Please use the watch command"- , (Rebuild $ verboseFlag def) &= help "Clean and build again"- , (Server (verboseFlag def) (hostFlag defaultHost) (portFlag defaultPort)) &=- help "Start a preview server"- , (Watch (verboseFlag def) (hostFlag defaultHost) (portFlag defaultPort) (noServerFlag False) &=- help "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server.")- ] &= help "Hakyll static site compiler" &= program progName- where- defaultHost = Config.previewHost conf- defaultPort = Config.previewPort conf-----------------------------------------------------------------------------------verboseFlag :: Data a => a -> a-verboseFlag x = x &= help "Run in verbose mode"-{-# INLINE verboseFlag #-}------------------------------------------------------------------------------------noServerFlag :: Data a => a -> a-noServerFlag x = x &= help "Disable the built-in web server"-{-# INLINE noServerFlag #-}-----------------------------------------------------------------------------------hostFlag :: Data a => a -> a-hostFlag x = x &= help "Host to bind on"-{-# INLINE hostFlag #-}-----------------------------------------------------------------------------------portFlag :: Data a => a -> a-portFlag x = x &= help "Port to listen on"-{-# INLINE portFlag #-}-------------------------------------------------------------------------------------- | This is necessary because not everyone calls their program the same...-progName :: String-progName = unsafePerformIO getProgName-{-# NOINLINE progName #-}
− src/Hakyll/Preview/Poll.hs
@@ -1,119 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-module Hakyll.Preview.Poll- ( watchUpdates- ) where------------------------------------------------------------------------------------import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (newEmptyMVar, takeMVar,- tryPutMVar)-import Control.Exception (AsyncException, fromException,- handle, throw)-import Control.Monad (forever, void, when)-import System.Directory (canonicalizePath)-import System.FilePath (pathSeparators)-import System.FSNotify (Event (..), startManager,- watchTree)--#ifdef mingw32_HOST_OS-import Control.Concurrent (threadDelay)-import Control.Exception (IOException, throw, try)-import System.Directory (doesFileExist)-import System.Exit (exitFailure)-import System.FilePath ((</>))-import System.IO (Handle, IOMode (ReadMode),- hClose, openFile)-import System.IO.Error (isPermissionError)-#endif------------------------------------------------------------------------------------import Hakyll.Core.Configuration-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-------------------------------------------------------------------------------------- | A thread that watches for updates in a 'providerDirectory' and recompiles--- a site as soon as any changes occur-watchUpdates :: Configuration -> IO Pattern -> IO ()-watchUpdates conf update = do- let providerDir = providerDirectory conf- shouldBuild <- newEmptyMVar- pattern <- update- fullProviderDir <- canonicalizePath $ providerDirectory conf- manager <- startManager-- let allowed event = do- -- Absolute path of the changed file. This must be inside provider- -- dir, since that's the only dir we're watching.- let path = eventPath event- relative = dropWhile (`elem` pathSeparators) $- drop (length fullProviderDir) path- identifier = fromFilePath relative-- shouldIgnore <- shouldIgnoreFile conf path- return $ not shouldIgnore && matches pattern identifier-- -- This thread continually watches the `shouldBuild` MVar and builds- -- whenever a value is present.- _ <- forkIO $ forever $ do- event <- takeMVar shouldBuild- handle- (\e -> case fromException e of- Nothing -> putStrLn (show e)- Just async -> throw (async :: AsyncException))- (update' event providerDir)-- -- Send an event whenever something occurs so that the thread described- -- above will do a build.- void $ watchTree manager providerDir (not . isRemove) $ \event -> do- allowed' <- allowed event- when allowed' $ void $ tryPutMVar shouldBuild event- where-#ifndef mingw32_HOST_OS- update' _ _ = void update-#else- update' event provider = do- let path = provider </> eventPath event- -- on windows, a 'Modified' event is also sent on file deletion- fileExists <- doesFileExist path-- when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10-- -- continuously attempts to open the file in between sleep intervals- -- handler is run only once it is able to open the file- waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r- waitOpen _ _ _ 0 = do- putStrLn "[ERROR] Failed to retrieve modified file for regeneration"- exitFailure- waitOpen path mode handler retries = do- res <- try $ openFile path mode :: IO (Either IOException Handle)- case res of- Left ex -> if isPermissionError ex- then do- threadDelay 100000- waitOpen path mode handler (retries - 1)- else throw ex- Right h -> do- handled <- handler h- hClose h- return handled-#endif------------------------------------------------------------------------------------eventPath :: Event -> FilePath-eventPath evt = evtPath evt- where- evtPath (Added p _) = p- evtPath (Modified p _) = p- evtPath (Removed p _) = p------------------------------------------------------------------------------------isRemove :: Event -> Bool-isRemove (Removed _ _) = True-isRemove _ = False
− src/Hakyll/Preview/Server.hs
@@ -1,54 +0,0 @@------------------------------------------------------------------------------------ | Implements a basic static file server for previewing options-{-# LANGUAGE OverloadedStrings #-}-module Hakyll.Preview.Server- ( staticServer- ) where------------------------------------------------------------------------------------import Control.Monad.Trans (liftIO)-import qualified Data.ByteString.Char8 as B-import qualified Snap.Core as Snap-import qualified Snap.Http.Server as Snap-import qualified Snap.Util.FileServe as Snap------------------------------------------------------------------------------------import Hakyll.Core.Logger (Logger)-import qualified Hakyll.Core.Logger as Logger-------------------------------------------------------------------------------------- | Serve a given directory-static :: FilePath -- ^ Directory to serve- -> (FilePath -> IO ()) -- ^ Pre-serve hook- -> Snap.Snap ()-static directory preServe =- Snap.serveDirectoryWith directoryConfig directory- where- directoryConfig :: Snap.DirectoryConfig Snap.Snap- directoryConfig = Snap.fancyDirectoryConfig- { Snap.preServeHook = liftIO . preServe- }-------------------------------------------------------------------------------------- | Main method, runs a static server in the given directory-staticServer :: Logger -- ^ Logger- -> FilePath -- ^ Directory to serve- -> (FilePath -> IO ()) -- ^ Pre-serve hook- -> String -- ^ Host to bind on- -> Int -- ^ Port to listen on- -> IO () -- ^ Blocks forever-staticServer logger directory preServe host port = do- Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port- Snap.httpServe config $ static directory preServe- where- -- Snap server config- config = Snap.setBind (B.pack host)- $ Snap.setPort port- $ Snap.setAccessLog Snap.ConfigNoLog- $ Snap.setErrorLog Snap.ConfigNoLog- $ Snap.setVerbose False- $ Snap.emptyConfig
− src/Hakyll/Web/CompressCss.hs
@@ -1,59 +0,0 @@------------------------------------------------------------------------------------ | Module used for CSS compression. The compression is currently in a simple--- state, but would typically reduce the number of bytes by about 25%.-module Hakyll.Web.CompressCss- ( compressCssCompiler- , compressCss- ) where------------------------------------------------------------------------------------import Data.Char (isSpace)-import Data.List (isPrefixOf)------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Item-import Hakyll.Core.Util.String-------------------------------------------------------------------------------------- | Compiler form of 'compressCss'-compressCssCompiler :: Compiler (Item String)-compressCssCompiler = fmap compressCss <$> getResourceString-------------------------------------------------------------------------------------- | Compress CSS to speed up your site.-compressCss :: String -> String-compressCss = compressSeparators . stripComments . compressWhitespace-------------------------------------------------------------------------------------- | Compresses certain forms of separators.-compressSeparators :: String -> String-compressSeparators =- replaceAll "; *}" (const "}") .- replaceAll " *([{};:]) *" (take 1 . dropWhile isSpace) .- replaceAll ";+" (const ";")-------------------------------------------------------------------------------------- | Compresses all whitespace.-compressWhitespace :: String -> String-compressWhitespace = replaceAll "[ \t\n\r]+" (const " ")-------------------------------------------------------------------------------------- | Function that strips CSS comments away.-stripComments :: String -> String-stripComments [] = []-stripComments str- | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str- | otherwise = head str : stripComments (drop 1 str)- where- eatComments str'- | null str' = []- | isPrefixOf "*/" str' = drop 2 str'- | otherwise = eatComments $ drop 1 str'
− src/Hakyll/Web/Feed.hs
@@ -1,131 +0,0 @@------------------------------------------------------------------------------------ | A Module that allows easy rendering of RSS feeds.------ The main rendering functions (@renderRss@, @renderAtom@) all assume that--- you pass the list of items so that the most recent entry in the feed is the--- first item in the list.------ Also note that the context should have (at least) the following fields to--- produce a correct feed:------ - @$title$@: Title of the item------ - @$description$@: Description to appear in the feed------ - @$url$@: URL to the item - this is usually set automatically.------ In addition, the posts should be named according to the rules for--- 'Hakyll.Web.Template.Context.dateField'-module Hakyll.Web.Feed- ( FeedConfiguration (..)- , renderRss- , renderAtom- ) where------------------------------------------------------------------------------------import Control.Monad ((<=<))------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Item-import Hakyll.Web.Template-import Hakyll.Web.Template.Context-import Hakyll.Web.Template.List------------------------------------------------------------------------------------import Paths_hakyll-------------------------------------------------------------------------------------- | This is a data structure to keep the configuration of a feed.-data FeedConfiguration = FeedConfiguration- { -- | Title of the feed.- feedTitle :: String- , -- | Description of the feed.- feedDescription :: String- , -- | Name of the feed author.- feedAuthorName :: String- , -- | Email of the feed author.- feedAuthorEmail :: String- , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@)- feedRoot :: String- } deriving (Show, Eq)-------------------------------------------------------------------------------------- | Abstract function to render any feed.-renderFeed :: FilePath -- ^ Feed template- -> FilePath -- ^ Item template- -> FeedConfiguration -- ^ Feed configuration- -> Context String -- ^ Context for the items- -> [Item String] -- ^ Input items- -> Compiler (Item String) -- ^ Resulting item-renderFeed feedPath itemPath config itemContext items = do- feedTpl <- compilerUnsafeIO $ loadTemplate feedPath- itemTpl <- compilerUnsafeIO $ loadTemplate itemPath-- body <- makeItem =<< applyTemplateList itemTpl itemContext' items- applyTemplate feedTpl feedContext body- where- -- Auxiliary: load a template from a datafile- loadTemplate = fmap readTemplate . readFile <=< getDataFileName-- itemContext' = mconcat- [ itemContext- , constField "root" (feedRoot config)- , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)- ]-- feedContext = mconcat- [ bodyField "body"- , constField "title" (feedTitle config)- , constField "description" (feedDescription config)- , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)- , constField "root" (feedRoot config)- , urlField "url"- , updatedField- , missingField- ]-- -- Take the first "updated" field from all items -- this should be the most- -- recent.- updatedField = field "updated" $ \_ -> case items of- [] -> return "Unknown"- (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of- ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"- StringField s -> return s-------------------------------------------------------------------------------------- | Render an RSS feed with a number of items.-renderRss :: FeedConfiguration -- ^ Feed configuration- -> Context String -- ^ Item context- -> [Item String] -- ^ Feed items- -> Compiler (Item String) -- ^ Resulting feed-renderRss config context = renderFeed- "templates/rss.xml" "templates/rss-item.xml" config- (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)-------------------------------------------------------------------------------------- | Render an Atom feed with a number of items.-renderAtom :: FeedConfiguration -- ^ Feed configuration- -> Context String -- ^ Item context- -> [Item String] -- ^ Feed items- -> Compiler (Item String) -- ^ Resulting feed-renderAtom config context = renderFeed- "templates/atom.xml" "templates/atom-item.xml" config- (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)-------------------------------------------------------------------------------------- | Copies @$updated$@ from @$published$@ if it is not already set.-makeItemContext :: String -> Context a -> Context a-makeItemContext fmt context = mconcat- [dateField "published" fmt, context, dateField "updated" fmt]
− src/Hakyll/Web/Html.hs
@@ -1,184 +0,0 @@------------------------------------------------------------------------------------ | Provides utilities to manipulate HTML pages-module Hakyll.Web.Html- ( -- * Generic- withTags-- -- * Headers- , demoteHeaders-- -- * Url manipulation- , getUrls- , withUrls- , toUrl- , toSiteRoot- , isExternal-- -- * Stripping/escaping- , stripTags- , escapeHtml- ) where------------------------------------------------------------------------------------import Data.Char (digitToInt, intToDigit,- isDigit, toLower)-import Data.List (isPrefixOf)-import qualified Data.Set as S-import System.FilePath.Posix (joinPath, splitPath,- takeDirectory)-import Text.Blaze.Html (toHtml)-import Text.Blaze.Html.Renderer.String (renderHtml)-import qualified Text.HTML.TagSoup as TS-import Network.URI (isUnreserved, escapeURIString)-------------------------------------------------------------------------------------- | Map over all tags in the document-withTags :: (TS.Tag String -> TS.Tag String) -> String -> String-withTags f = renderTags' . map f . parseTags'-------------------------------------------------------------------------------------- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.-demoteHeaders :: String -> String-demoteHeaders = withTags $ \tag -> case tag of- TS.TagOpen t a -> TS.TagOpen (demote t) a- TS.TagClose t -> TS.TagClose (demote t)- t -> t- where- demote t@['h', n]- | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]- | otherwise = t- demote t = t------------------------------------------------------------------------------------isUrlAttribute :: String -> Bool-isUrlAttribute = (`elem` ["src", "href", "data", "poster"])------------------------------------------------------------------------------------getUrls :: [TS.Tag String] -> [String]-getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]-------------------------------------------------------------------------------------- | Apply a function to each URL on a webpage-withUrls :: (String -> String) -> String -> String-withUrls f = withTags tag- where- tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a- tag x = x- attr (k, v) = (k, if isUrlAttribute k then f v else v)-------------------------------------------------------------------------------------- | Customized TagSoup renderer. The default TagSoup renderer escape CSS--- within style tags, and doesn't properly minimize.-renderTags' :: [TS.Tag String] -> String-renderTags' = TS.renderTagsOptions TS.RenderOptions- { TS.optRawTag = (`elem` ["script", "style"]) . map toLower- , TS.optMinimize = (`S.member` minimize) . map toLower- , TS.optEscape = id- }- where- -- A list of elements which must be minimized- minimize = S.fromList- [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"- , "param"- ]-------------------------------------------------------------------------------------- | Customized TagSoup parser: do not decode any entities.-parseTags' :: String -> [TS.Tag String]-parseTags' = TS.parseTagsOptions (TS.parseOptions :: TS.ParseOptions String)- { TS.optEntityData = \(str, b) -> [TS.TagText $ "&" ++ str ++ [';' | b]]- , TS.optEntityAttrib = \(str, b) -> ("&" ++ str ++ [';' | b], [])- }-------------------------------------------------------------------------------------- | Convert a filepath to an URL starting from the site root------ Example:------ > toUrl "foo/bar.html"------ Result:------ > "/foo/bar.html"------ This also sanitizes the URL, e.g. converting spaces into '%20'-toUrl :: FilePath -> String-toUrl url = case url of- ('/' : xs) -> '/' : sanitize xs- xs -> '/' : sanitize xs- where- -- Everything but unreserved characters should be escaped as we are- -- sanitising the path therefore reserved characters which have a- -- meaning in URI does not appear. Special casing for `/`, because it has- -- a special meaning in FilePath as well as in URI.- sanitize = escapeURIString (\c -> c == '/' || isUnreserved c)-------------------------------------------------------------------------------------- | Get the relative url to the site root, for a given (absolute) url-toSiteRoot :: String -> String-toSiteRoot = emptyException . joinPath . map parent- . filter relevant . splitPath . takeDirectory- where- parent = const ".."- emptyException [] = "."- emptyException x = x- relevant "." = False- relevant "/" = False- relevant "./" = False- relevant _ = True-------------------------------------------------------------------------------------- | Check if an URL links to an external HTTP(S) source-isExternal :: String -> Bool-isExternal url = any (flip isPrefixOf url) ["http://", "https://", "//"]-------------------------------------------------------------------------------------- | Strip all HTML tags from a string------ Example:------ > stripTags "<p>foo</p>"------ Result:------ > "foo"------ This also works for incomplete tags------ Example:------ > stripTags "<p>foo</p"------ Result:------ > "foo"-stripTags :: String -> String-stripTags [] = []-stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs-stripTags (x : xs) = x : stripTags xs-------------------------------------------------------------------------------------- | HTML-escape a string------ Example:------ > escapeHtml "Me & Dean"------ Result:------ > "Me & Dean"-escapeHtml :: String -> String-escapeHtml = renderHtml . toHtml
− src/Hakyll/Web/Html/RelativizeUrls.hs
@@ -1,52 +0,0 @@------------------------------------------------------------------------------------ | This module exposes a function which can relativize URL's on a webpage.------ This means that one can deploy the resulting site on--- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@--- without having to change anything (simply copy over the files).------ To use it, you should use absolute URL's from the site root everywhere. For--- example, use------ > <img src="/images/lolcat.png" alt="Funny zomgroflcopter" />------ in a blogpost. When running this through the relativize URL's module, this--- will result in (suppose your blogpost is located at @\/posts\/foo.html@:------ > <img src="../images/lolcat.png" alt="Funny zomgroflcopter" />-module Hakyll.Web.Html.RelativizeUrls- ( relativizeUrls- , relativizeUrlsWith- ) where------------------------------------------------------------------------------------import Data.List (isPrefixOf)------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Item-import Hakyll.Web.Html-------------------------------------------------------------------------------------- | Compiler form of 'relativizeUrls' which automatically picks the right root--- path-relativizeUrls :: Item String -> Compiler (Item String)-relativizeUrls item = do- route <- getRoute $ itemIdentifier item- return $ case route of- Nothing -> item- Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item-------------------------------------------------------------------------------------- | Relativize URL's in HTML-relativizeUrlsWith :: String -- ^ Path to the site root- -> String -- ^ HTML to relativize- -> String -- ^ Resulting HTML-relativizeUrlsWith root = withUrls rel- where- isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)- rel x = if isRel x then root ++ x else x
− src/Hakyll/Web/Paginate.hs
@@ -1,126 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings #-}-module Hakyll.Web.Paginate- ( PageNumber- , Paginate (..)- , buildPaginateWith- , paginateEvery- , paginateRules- , paginateContext- ) where------------------------------------------------------------------------------------import Control.Monad (forM_)-import qualified Data.Map as M-import qualified Data.Set as S------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Core.Rules-import Hakyll.Web.Html-import Hakyll.Web.Template.Context------------------------------------------------------------------------------------type PageNumber = Int-------------------------------------------------------------------------------------- | Data about paginators-data Paginate = Paginate- { paginateMap :: M.Map PageNumber [Identifier]- , paginateMakeId :: PageNumber -> Identifier- , paginateDependency :: Dependency- }------------------------------------------------------------------------------------paginateNumPages :: Paginate -> Int-paginateNumPages = M.size . paginateMap------------------------------------------------------------------------------------paginateEvery :: Int -> [a] -> [[a]]-paginateEvery n = go- where- go [] = []- go xs = let (y, ys) = splitAt n xs in y : go ys------------------------------------------------------------------------------------buildPaginateWith- :: MonadMetadata m- => ([Identifier] -> m [[Identifier]]) -- ^ Group items into pages- -> Pattern -- ^ Select items to paginate- -> (PageNumber -> Identifier) -- ^ Identifiers for the pages- -> m Paginate-buildPaginateWith grouper pattern makeId = do- ids <- getMatches pattern- idGroups <- grouper ids- let idsSet = S.fromList ids- return Paginate- { paginateMap = M.fromList (zip [1 ..] idGroups)- , paginateMakeId = makeId- , paginateDependency = PatternDependency pattern idsSet- }------------------------------------------------------------------------------------paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()-paginateRules paginator rules =- forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) ->- rulesExtraDependencies [paginateDependency paginator] $- create [paginateMakeId paginator idx] $- rules idx $ fromList identifiers-------------------------------------------------------------------------------------- | Get the identifier for a certain page by passing in the page number.-paginatePage :: Paginate -> PageNumber -> Maybe Identifier-paginatePage pag pageNumber- | pageNumber < 1 = Nothing- | pageNumber > (paginateNumPages pag) = Nothing- | otherwise = Just $ paginateMakeId pag pageNumber-------------------------------------------------------------------------------------- | A default paginate context which provides the following keys:-------paginateContext :: Paginate -> PageNumber -> Context a-paginateContext pag currentPage = mconcat- [ field "firstPageNum" $ \_ -> otherPage 1 >>= num- , field "firstPageUrl" $ \_ -> otherPage 1 >>= url- , field "previousPageNum" $ \_ -> otherPage (currentPage - 1) >>= num- , field "previousPageUrl" $ \_ -> otherPage (currentPage - 1) >>= url- , field "nextPageNum" $ \_ -> otherPage (currentPage + 1) >>= num- , field "nextPageUrl" $ \_ -> otherPage (currentPage + 1) >>= url- , field "lastPageNum" $ \_ -> otherPage lastPage >>= num- , field "lastPageUrl" $ \_ -> otherPage lastPage >>= url- , field "currentPageNum" $ \i -> thisPage i >>= num- , field "currentPageUrl" $ \i -> thisPage i >>= url- , constField "numPages" $ show $ paginateNumPages pag- ]- where- lastPage = paginateNumPages pag-- thisPage i = return (currentPage, itemIdentifier i)- otherPage n- | n == currentPage = fail $ "This is the current page: " ++ show n- | otherwise = case paginatePage pag n of- Nothing -> fail $ "No such page: " ++ show n- Just i -> return (n, i)-- num :: (Int, Identifier) -> Compiler String- num = return . show . fst-- url :: (Int, Identifier) -> Compiler String- url (n, i) = getRoute i >>= \mbR -> case mbR of- Just r -> return $ toUrl r- Nothing -> fail $ "No URL for page: " ++ show n
− src/Hakyll/Web/Pandoc.hs
@@ -1,164 +0,0 @@------------------------------------------------------------------------------------ | Module exporting convenient pandoc bindings-module Hakyll.Web.Pandoc- ( -- * The basic building blocks- readPandoc- , readPandocWith- , writePandoc- , writePandocWith- , renderPandoc- , renderPandocWith-- -- * Derived compilers- , pandocCompiler- , pandocCompilerWith- , pandocCompilerWithTransform- , pandocCompilerWithTransformM-- -- * Default options- , defaultHakyllReaderOptions- , defaultHakyllWriterOptions- ) where------------------------------------------------------------------------------------import qualified Data.Set as S-import Text.Pandoc-import Text.Pandoc.Error (PandocError (..))------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Item-import Hakyll.Web.Pandoc.FileType-------------------------------------------------------------------------------------- | Read a string using pandoc, with the default options-readPandoc- :: Item String -- ^ String to read- -> Compiler (Item Pandoc) -- ^ Resulting document-readPandoc = readPandocWith defaultHakyllReaderOptions-------------------------------------------------------------------------------------- | Read a string using pandoc, with the supplied options-readPandocWith- :: ReaderOptions -- ^ Parser options- -> Item String -- ^ String to read- -> Compiler (Item Pandoc) -- ^ Resulting document-readPandocWith ropt item =- case traverse (reader ropt (itemFileType item)) item of- Left (ParseFailure err) -> fail $- "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ err- Left (ParsecError _ err) -> fail $- "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ show err- Right item' -> return item'- where- reader ro t = case t of- DocBook -> readDocBook ro- Html -> readHtml ro- LaTeX -> readLaTeX ro- LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'- Markdown -> readMarkdown ro- MediaWiki -> readMediaWiki ro- OrgMode -> readOrg ro- Rst -> readRST ro- Textile -> readTextile ro- _ -> error $- "Hakyll.Web.readPandocWith: I don't know how to read a file of " ++- "the type " ++ show t ++ " for: " ++ show (itemIdentifier item)-- addExt ro e = ro {readerExtensions = S.insert e $ readerExtensions ro}-------------------------------------------------------------------------------------- | Write a document (as HTML) using pandoc, with the default options-writePandoc :: Item Pandoc -- ^ Document to write- -> Item String -- ^ Resulting HTML-writePandoc = writePandocWith defaultHakyllWriterOptions-------------------------------------------------------------------------------------- | Write a document (as HTML) using pandoc, with the supplied options-writePandocWith :: WriterOptions -- ^ Writer options for pandoc- -> Item Pandoc -- ^ Document to write- -> Item String -- ^ Resulting HTML-writePandocWith wopt = fmap $ writeHtmlString wopt-------------------------------------------------------------------------------------- | Render the resource using pandoc-renderPandoc :: Item String -> Compiler (Item String)-renderPandoc =- renderPandocWith defaultHakyllReaderOptions defaultHakyllWriterOptions-------------------------------------------------------------------------------------- | Render the resource using pandoc-renderPandocWith- :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String)-renderPandocWith ropt wopt item =- writePandocWith wopt <$> readPandocWith ropt item-------------------------------------------------------------------------------------- | Read a page render using pandoc-pandocCompiler :: Compiler (Item String)-pandocCompiler =- pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions-------------------------------------------------------------------------------------- | A version of 'pandocCompiler' which allows you to specify your own pandoc--- options-pandocCompilerWith :: ReaderOptions -> WriterOptions -> Compiler (Item String)-pandocCompilerWith ropt wopt =- cached "Hakyll.Web.Pandoc.pandocCompilerWith" $- pandocCompilerWithTransform ropt wopt id-------------------------------------------------------------------------------------- | An extension of 'pandocCompilerWith' which allows you to specify a custom--- pandoc transformation for the content-pandocCompilerWithTransform :: ReaderOptions -> WriterOptions- -> (Pandoc -> Pandoc)- -> Compiler (Item String)-pandocCompilerWithTransform ropt wopt f =- pandocCompilerWithTransformM ropt wopt (return . f)-------------------------------------------------------------------------------------- | Similar to 'pandocCompilerWithTransform', but the transformation--- function is monadic. This is useful when you want the pandoc--- transformation to use the 'Compiler' information such as routes,--- metadata, etc-pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions- -> (Pandoc -> Compiler Pandoc)- -> Compiler (Item String)-pandocCompilerWithTransformM ropt wopt f =- writePandocWith wopt <$>- (traverse f =<< readPandocWith ropt =<< getResourceBody)-------------------------------------------------------------------------------------- | The default reader options for pandoc parsing in hakyll-defaultHakyllReaderOptions :: ReaderOptions-defaultHakyllReaderOptions = def- { -- The following option causes pandoc to read smart typography, a nice- -- and free bonus.- readerSmart = True- }-------------------------------------------------------------------------------------- | The default writer options for pandoc rendering in hakyll-defaultHakyllWriterOptions :: WriterOptions-defaultHakyllWriterOptions = def- { -- This option causes literate haskell to be written using '>' marks in- -- html, which I think is a good default.- writerExtensions = S.insert Ext_literate_haskell (writerExtensions def)- , -- We want to have hightlighting by default, to be compatible with earlier- -- Hakyll releases- writerHighlight = True- }
− src/Hakyll/Web/Pandoc/Biblio.hs
@@ -1,115 +0,0 @@------------------------------------------------------------------------------------ | Wraps pandocs bibiliography handling------ In order to add a bibliography, you will need a bibliography file (e.g.--- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their--- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can--- refer to these files when you use 'readPandocBiblio'. This function also--- takes the reader options for completeness -- you can use--- 'defaultHakyllReaderOptions' if you're unsure.--- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',--- but also takes paths to compiled bibliography and csl files.-{-# LANGUAGE Arrows #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Hakyll.Web.Pandoc.Biblio- ( CSL- , cslCompiler- , Biblio (..)- , biblioCompiler- , readPandocBiblio- , pandocBiblioCompiler- ) where------------------------------------------------------------------------------------import Control.Monad (liftM, replicateM)-import Data.Binary (Binary (..))-import Data.Default (def)-import Data.Typeable (Typeable)-import Hakyll.Core.Compiler-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Core.Writable-import Hakyll.Web.Pandoc-import Hakyll.Web.Pandoc.Binary ()-import qualified Text.CSL as CSL-import Text.CSL.Pandoc (processCites)-import Text.Pandoc (Pandoc, ReaderOptions (..))------------------------------------------------------------------------------------data CSL = CSL- deriving (Show, Typeable)------------------------------------------------------------------------------------instance Binary CSL where- put CSL = return ()- get = return CSL------------------------------------------------------------------------------------instance Writable CSL where- -- Shouldn't be written.- write _ _ = return ()------------------------------------------------------------------------------------cslCompiler :: Compiler (Item CSL)-cslCompiler = makeItem CSL------------------------------------------------------------------------------------newtype Biblio = Biblio [CSL.Reference]- deriving (Show, Typeable)------------------------------------------------------------------------------------instance Binary Biblio where- -- Ugly.- get = do- len <- get- Biblio <$> replicateM len get- put (Biblio rs) = put (length rs) >> mapM_ put rs------------------------------------------------------------------------------------instance Writable Biblio where- -- Shouldn't be written.- write _ _ = return ()------------------------------------------------------------------------------------biblioCompiler :: Compiler (Item Biblio)-biblioCompiler = do- filePath <- toFilePath <$> getUnderlying- makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath)------------------------------------------------------------------------------------readPandocBiblio :: ReaderOptions- -> Item CSL- -> Item Biblio- -> (Item String)- -> Compiler (Item Pandoc)-readPandocBiblio ropt csl biblio item = do- -- Parse CSL file, if given- style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl-- -- We need to know the citation keys, add then *before* actually parsing the- -- actual page. If we don't do this, pandoc won't even consider them- -- citations!- let Biblio refs = itemBody biblio- pandoc <- itemBody <$> readPandocWith ropt item- let pandoc' = processCites style refs pandoc-- return $ fmap (const pandoc') item-----------------------------------------------------------------------------------pandocBiblioCompiler :: String -> String -> Compiler (Item String)-pandocBiblioCompiler cslFileName bibFileName = do- csl <- load $ fromFilePath cslFileName- bib <- load $ fromFilePath bibFileName- liftM writePandoc- (getResourceBody >>= readPandocBiblio def csl bib)
− src/Hakyll/Web/Pandoc/Binary.hs
@@ -1,31 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveGeneric #-}-module Hakyll.Web.Pandoc.Binary where--import Data.Binary (Binary (..))--import qualified Text.CSL as CSL-import qualified Text.CSL.Reference as REF-import qualified Text.CSL.Style as STY-import Text.Pandoc ------------------------------------------------------------------------------------- orphans--instance Binary REF.CNum-instance Binary REF.Literal-instance Binary REF.RefDate-instance Binary REF.RefType-instance Binary STY.Agent-instance Binary STY.Formatted-instance Binary Inline-instance Binary Block-instance Binary Citation-instance Binary MathType-instance Binary Alignment-instance Binary CitationMode-instance Binary QuoteType-instance Binary Format-instance Binary ListNumberDelim-instance Binary ListNumberStyle-instance Binary CSL.Reference
− src/Hakyll/Web/Pandoc/FileType.hs
@@ -1,74 +0,0 @@------------------------------------------------------------------------------------ | A module dealing with pandoc file extensions and associated file types-module Hakyll.Web.Pandoc.FileType- ( FileType (..)- , fileType- , itemFileType- ) where------------------------------------------------------------------------------------import System.FilePath (splitExtension)------------------------------------------------------------------------------------import Hakyll.Core.Identifier-import Hakyll.Core.Item-------------------------------------------------------------------------------------- | Datatype to represent the different file types Hakyll can deal with by--- default-data FileType- = Binary- | Css- | DocBook- | Html- | LaTeX- | LiterateHaskell FileType- | Markdown- | MediaWiki- | OrgMode- | PlainText- | Rst- | Textile- deriving (Eq, Ord, Show, Read)-------------------------------------------------------------------------------------- | Get the file type for a certain file. The type is determined by extension.-fileType :: FilePath -> FileType-fileType = uncurry fileType' . splitExtension- where- fileType' _ ".css" = Css- fileType' _ ".dbk" = DocBook- fileType' _ ".htm" = Html- fileType' _ ".html" = Html- fileType' f ".lhs" = LiterateHaskell $ case fileType f of- -- If no extension is given, default to Markdown + LiterateHaskell- Binary -> Markdown- -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified- x -> x- fileType' _ ".markdown" = Markdown- fileType' _ ".mediawiki" = MediaWiki- fileType' _ ".md" = Markdown- fileType' _ ".mdn" = Markdown- fileType' _ ".mdown" = Markdown- fileType' _ ".mdwn" = Markdown- fileType' _ ".mkd" = Markdown- fileType' _ ".mkdwn" = Markdown- fileType' _ ".org" = OrgMode- fileType' _ ".page" = Markdown- fileType' _ ".rst" = Rst- fileType' _ ".tex" = LaTeX- fileType' _ ".text" = PlainText- fileType' _ ".textile" = Textile- fileType' _ ".txt" = PlainText- fileType' _ ".wiki" = MediaWiki- fileType' _ _ = Binary -- Treat unknown files as binary-------------------------------------------------------------------------------------- | Get the file type for the current file-itemFileType :: Item a -> FileType-itemFileType = fileType . toFilePath . itemIdentifier
− src/Hakyll/Web/Tags.hs
@@ -1,344 +0,0 @@------------------------------------------------------------------------------------ | This module containing some specialized functions to deal with tags. It--- assumes you follow some conventions.------ We support two types of tags: tags and categories.------ To use default tags, use 'buildTags'. Tags are placed in a comma-separated--- metadata field like this:------ > ------ > author: Philip K. Dick--- > title: Do androids dream of electric sheep?--- > tags: future, science fiction, humanoid--- > ------ > The novel is set in a post-apocalyptic near future, where the Earth and--- > its populations have been damaged greatly by Nuclear...------ To use categories, use the 'buildCategories' function. Categories are--- determined by the directory a page is in, for example, the post------ > posts/coding/2010-01-28-hakyll-categories.markdown------ will receive the @coding@ category.------ Advanced users may implement custom systems using 'buildTagsWith' if desired.------ In the above example, we would want to create a page which lists all pages in--- the @coding@ category, for example, with the 'Identifier':------ > tags/coding.html------ This is where the first parameter of 'buildTags' and 'buildCategories' comes--- in. In the above case, we used the function:------ > fromCapture "tags/*.html" :: String -> Identifier------ The 'tagsRules' function lets you generate such a page for each tag in the--- 'Rules' monad.-{-# LANGUAGE Arrows #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-module Hakyll.Web.Tags- ( Tags (..)- , getTags- , buildTagsWith- , buildTags- , buildCategories- , tagsRules- , renderTags- , renderTagCloud- , renderTagCloudWith- , tagCloudField- , tagCloudFieldWith- , renderTagList- , tagsField- , tagsFieldWith- , categoryField- , sortTagsBy- , caseInsensitiveTags- ) where------------------------------------------------------------------------------------import Control.Arrow ((&&&))-import Control.Monad (foldM, forM, forM_, mplus)-import Data.Char (toLower)-import Data.List (intercalate, intersperse,- sortBy)-import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe)-import Data.Ord (comparing)-import qualified Data.Set as S-import System.FilePath (takeBaseName, takeDirectory)-import Text.Blaze.Html (toHtml, toValue, (!))-import Text.Blaze.Html.Renderer.String (renderHtml)-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Dependencies-import Hakyll.Core.Identifier-import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Core.Rules-import Hakyll.Core.Util.String-import Hakyll.Web.Html-import Hakyll.Web.Template.Context-------------------------------------------------------------------------------------- | Data about tags-data Tags = Tags- { tagsMap :: [(String, [Identifier])]- , tagsMakeId :: String -> Identifier- , tagsDependency :: Dependency- }-------------------------------------------------------------------------------------- | Obtain tags from a page in the default way: parse them from the @tags@--- metadata field. This can either be a list or a comma-separated string.-getTags :: MonadMetadata m => Identifier -> m [String]-getTags identifier = do- metadata <- getMetadata identifier- return $ fromMaybe [] $- (lookupStringList "tags" metadata) `mplus`- (map trim . splitAll "," <$> lookupString "tags" metadata)-------------------------------------------------------------------------------------- | Obtain categories from a page.-getCategory :: MonadMetadata m => Identifier -> m [String]-getCategory = return . return . takeBaseName . takeDirectory . toFilePath-------------------------------------------------------------------------------------- | Higher-order function to read tags-buildTagsWith :: MonadMetadata m- => (Identifier -> m [String])- -> Pattern- -> (String -> Identifier)- -> m Tags-buildTagsWith f pattern makeId = do- ids <- getMatches pattern- tagMap <- foldM addTags M.empty ids- let set' = S.fromList ids- return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set')- where- -- Create a tag map for one page- addTags tagMap id' = do- tags <- f id'- let tagMap' = M.fromList $ zip tags $ repeat [id']- return $ M.unionWith (++) tagMap tagMap'------------------------------------------------------------------------------------buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags-buildTags = buildTagsWith getTags------------------------------------------------------------------------------------buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)- -> m Tags-buildCategories = buildTagsWith getCategory------------------------------------------------------------------------------------tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()-tagsRules tags rules =- forM_ (tagsMap tags) $ \(tag, identifiers) ->- rulesExtraDependencies [tagsDependency tags] $- create [tagsMakeId tags tag] $- rules tag $ fromList identifiers-------------------------------------------------------------------------------------- | Render tags in HTML (the flexible higher-order function)-renderTags :: (String -> String -> Int -> Int -> Int -> String)- -- ^ Produce a tag item: tag, url, count, min count, max count- -> ([String] -> String)- -- ^ Join items- -> Tags- -- ^ Tag cloud renderer- -> Compiler String-renderTags makeHtml concatHtml tags = do- -- In tags' we create a list: [((tag, route), count)]- tags' <- forM (tagsMap tags) $ \(tag, ids) -> do- route' <- getRoute $ tagsMakeId tags tag- return ((tag, route'), length ids)-- -- TODO: We actually need to tell a dependency here!-- let -- Absolute frequencies of the pages- freqs = map snd tags'-- -- The minimum and maximum count found- (min', max')- | null freqs = (0, 1)- | otherwise = (minimum &&& maximum) freqs-- -- Create a link for one item- makeHtml' ((tag, url), count) =- makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'-- -- Render and return the HTML- return $ concatHtml $ map makeHtml' tags'-------------------------------------------------------------------------------------- | Render a tag cloud in HTML-renderTagCloud :: Double- -- ^ Smallest font size, in percent- -> Double- -- ^ Biggest font size, in percent- -> Tags- -- ^ Input tags- -> Compiler String- -- ^ Rendered cloud-renderTagCloud = renderTagCloudWith makeLink (intercalate " ")- where- makeLink minSize maxSize tag url count min' max' =- -- Show the relative size of one 'count' in percent- let diff = 1 + fromIntegral max' - fromIntegral min'- relative = (fromIntegral count - fromIntegral min') / diff- size = floor $ minSize + relative * (maxSize - minSize) :: Int- in renderHtml $- H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%")- ! A.href (toValue url)- $ toHtml tag-------------------------------------------------------------------------------------- | Render a tag cloud in HTML-renderTagCloudWith :: (Double -> Double ->- String -> String -> Int -> Int -> Int -> String)- -- ^ Render a single tag link- -> ([String] -> String)- -- ^ Concatenate links- -> Double- -- ^ Smallest font size, in percent- -> Double- -- ^ Biggest font size, in percent- -> Tags- -- ^ Input tags- -> Compiler String- -- ^ Rendered cloud-renderTagCloudWith makeLink cat minSize maxSize =- renderTags (makeLink minSize maxSize) cat-------------------------------------------------------------------------------------- | Render a tag cloud in HTML as a context-tagCloudField :: String- -- ^ Destination key- -> Double- -- ^ Smallest font size, in percent- -> Double- -- ^ Biggest font size, in percent- -> Tags- -- ^ Input tags- -> Context a- -- ^ Context-tagCloudField key minSize maxSize tags =- field key $ \_ -> renderTagCloud minSize maxSize tags-------------------------------------------------------------------------------------- | Render a tag cloud in HTML as a context-tagCloudFieldWith :: String- -- ^ Destination key- -> (Double -> Double ->- String -> String -> Int -> Int -> Int -> String)- -- ^ Render a single tag link- -> ([String] -> String)- -- ^ Concatenate links- -> Double- -- ^ Smallest font size, in percent- -> Double- -- ^ Biggest font size, in percent- -> Tags- -- ^ Input tags- -> Context a- -- ^ Context-tagCloudFieldWith key makeLink cat minSize maxSize tags =- field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags-------------------------------------------------------------------------------------- | Render a simple tag list in HTML, with the tag count next to the item--- TODO: Maybe produce a Context here-renderTagList :: Tags -> Compiler (String)-renderTagList = renderTags makeLink (intercalate ", ")- where- makeLink tag url count _ _ = renderHtml $- H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")-------------------------------------------------------------------------------------- | Render tags with links with custom functions to get tags and to--- render links-tagsFieldWith :: (Identifier -> Compiler [String])- -- ^ Get the tags- -> (String -> (Maybe FilePath) -> Maybe H.Html)- -- ^ Render link for one tag- -> ([H.Html] -> H.Html)- -- ^ Concatenate tag links- -> String- -- ^ Destination field- -> Tags- -- ^ Tags structure- -> Context a- -- ^ Resulting context-tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do- tags' <- getTags' $ itemIdentifier item- links <- forM tags' $ \tag -> do- route' <- getRoute $ tagsMakeId tags tag- return $ renderLink tag route'-- return $ renderHtml $ cat $ catMaybes $ links-------------------------------------------------------------------------------------- | Render tags with links-tagsField :: String -- ^ Destination key- -> Tags -- ^ Tags- -> Context a -- ^ Context-tagsField =- tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ")-------------------------------------------------------------------------------------- | Render the category in a link-categoryField :: String -- ^ Destination key- -> Tags -- ^ Tags- -> Context a -- ^ Context-categoryField =- tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ")-------------------------------------------------------------------------------------- | Render one tag link-simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html-simpleRenderLink _ Nothing = Nothing-simpleRenderLink tag (Just filePath) =- Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag-------------------------------------------------------------------------------------- | Sort tags using supplied function. First element of the tuple passed to--- the comparing function is the actual tag name.-sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)- -> Tags -> Tags-sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}-------------------------------------------------------------------------------------- | Sample sorting function that compares tags case insensitively.-caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])- -> Ordering-caseInsensitiveTags = comparing $ map toLower . fst
− src/Hakyll/Web/Template.hs
@@ -1,263 +0,0 @@--- | This module provides means for reading and applying 'Template's.------ Templates are tools to convert items into a string. They are perfectly suited--- for laying out your site.------ Let's look at an example template:------ > <html>--- > <head>--- > <title>My crazy homepage - $title$</title>--- > </head>--- > <body>--- > <div id="header">--- > <h1>My crazy homepage - $title$</h1>--- > </div>--- > <div id="content">--- > $body$--- > </div>--- > <div id="footer">--- > By reading this you agree that I now own your soul--- > </div>--- > </body>--- > </html>------ As you can see, the format is very simple -- @$key$@ is used to render the--- @$key$@ field from the page, everything else is literally copied. If you want--- to literally insert @\"$key$\"@ into your page (for example, when you're--- writing a Hakyll tutorial) you can use------ > <p>--- > A literal $$key$$.--- > </p>------ Because of it's simplicity, these templates can be used for more than HTML:--- you could make, for example, CSS or JS templates as well.------ Apart from interpolating @$key$@s from the 'Context' you can also--- use the following macros:------ * @$if(key)$@------ > $if(key)$--- > <b> Defined </b>--- > $else$--- > <b> Non-defined </b>--- > $endif$------ This example will print @Defined@ if @key@ is defined in the--- context and @Non-defined@ otherwise. The @$else$@ clause is--- optional.------ * @$for(key)$@------ The @for@ macro is used for enumerating 'Context' elements that are--- lists, i.e. constructed using the 'listField' function. Assume that--- in a context we have an element @listField \"key\" c itms@. Then--- the snippet------ > $for(key)$--- > $x$--- > $sep$,--- > $endfor$------ would, for each item @i@ in 'itms', lookup @$x$@ in the context @c@--- with item @i@, interpolate it, and join the resulting list with--- @,@.------ Another concrete example one may consider is the following. Given the--- context------ > listField "things" (field "thing" (return . itemBody))--- > (sequence [makeItem "fruits", makeItem "vegetables"])------ and a template------ > I like--- > $for(things)$--- > fresh $thing$$sep$, and--- > $endfor$------ the resulting page would look like------ > <p>--- > I like--- >--- > fresh fruits, and--- >--- > fresh vegetables--- > </p>------ The @$sep$@ part can be omitted. Usually, you can get by using the--- 'applyListTemplate' and 'applyJoinListTemplate' functions.------ * @$partial(path)$@------ Loads a template located in a separate file and interpolates it--- under the current context.------ Assuming that the file @test.html@ contains------ > <b>$key$</b>------ The result of rendering------ > <p>--- > $partial("test.html")$--- > </p>------ is the same as the result of rendering------ > <p>--- > <b>$key$</b>--- > </p>------ That is, calling @$partial$@ is equivalent to just copying and pasting--- template code.----{-# LANGUAGE ScopedTypeVariables #-}-module Hakyll.Web.Template- ( Template- , templateBodyCompiler- , templateCompiler- , applyTemplate- , loadAndApplyTemplate- , applyAsTemplate- , readTemplate- ) where------------------------------------------------------------------------------------import Control.Monad (liftM)-import Control.Monad.Except (MonadError (..))-import Data.List (intercalate)-import Prelude hiding (id)------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Web.Template.Context-import Hakyll.Web.Template.Internal-------------------------------------------------------------------------------------- | Read a template, without metadata header-templateBodyCompiler :: Compiler (Item Template)-templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do- item <- getResourceBody- return $ fmap readTemplate item------------------------------------------------------------------------------------- | Read complete file contents as a template-templateCompiler :: Compiler (Item Template)-templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do- item <- getResourceString- return $ fmap readTemplate item------------------------------------------------------------------------------------applyTemplate :: Template -- ^ Template- -> Context a -- ^ Context- -> Item a -- ^ Page- -> Compiler (Item String) -- ^ Resulting item-applyTemplate tpl context item = do- body <- applyTemplate' tpl context item- return $ itemSetBody body item------------------------------------------------------------------------------------applyTemplate'- :: forall a.- Template -- ^ Template- -> Context a -- ^ Context- -> Item a -- ^ Page- -> Compiler String -- ^ Resulting item-applyTemplate' tpl context x = go tpl- where- context' :: String -> [String] -> Item a -> Compiler ContextField- context' = unContext (context `mappend` missingField)-- go = liftM concat . mapM applyElem . unTemplate-- ----------------------------------------------------------------------------- applyElem :: TemplateElement -> Compiler String-- applyElem (Chunk c) = return c-- applyElem (Expr e) = applyExpr e >>= getString e-- applyElem Escaped = return "$"-- applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler- where- handler _ = case mf of- Nothing -> return ""- Just f -> go f-- applyElem (For e b s) = applyExpr e >>= \cf -> case cf of- StringField _ -> fail $- "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++- "got StringField for expr " ++ show e- ListField c xs -> do- sep <- maybe (return "") go s- bs <- mapM (applyTemplate' b c) xs- return $ intercalate sep bs-- applyElem (Partial e) = do- p <- applyExpr e >>= getString e- tpl' <- loadBody (fromFilePath p)- applyTemplate' tpl' context x-- ----------------------------------------------------------------------------- applyExpr :: TemplateExpr -> Compiler ContextField-- applyExpr (Ident (TemplateKey k)) = context' k [] x-- applyExpr (Call (TemplateKey k) args) = do- args' <- mapM (\e -> applyExpr e >>= getString e) args- context' k args' x-- applyExpr (StringLiteral s) = return (StringField s)-- ------------------------------------------------------------------------------ getString _ (StringField s) = return s- getString e (ListField _ _) = fail $- "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++- "got ListField for expr " ++ show e-------------------------------------------------------------------------------------- | The following pattern is so common:------ > tpl <- loadBody "templates/foo.html"--- > someCompiler--- > >>= applyTemplate tpl context------ That we have a single function which does this:------ > someCompiler--- > >>= loadAndApplyTemplate "templates/foo.html" context-loadAndApplyTemplate :: Identifier -- ^ Template identifier- -> Context a -- ^ Context- -> Item a -- ^ Page- -> Compiler (Item String) -- ^ Resulting item-loadAndApplyTemplate identifier context item = do- tpl <- loadBody identifier- applyTemplate tpl context item-------------------------------------------------------------------------------------- | It is also possible that you want to substitute @$key$@s within the body of--- an item. This function does that by interpreting the item body as a template,--- and then applying it to itself.-applyAsTemplate :: Context String -- ^ Context- -> Item String -- ^ Item and template- -> Compiler (Item String) -- ^ Resulting item-applyAsTemplate context item =- let tpl = readTemplate $ itemBody item- in applyTemplate tpl context item
− src/Hakyll/Web/Template/Context.hs
@@ -1,379 +0,0 @@----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-module Hakyll.Web.Template.Context- ( ContextField (..)- , Context (..)- , field- , boolField- , constField- , listField- , listFieldWith- , functionField- , mapContext-- , defaultContext- , bodyField- , metadataField- , urlField- , pathField- , titleField- , snippetField- , dateField- , dateFieldWith- , getItemUTC- , getItemModificationTime- , modificationTimeField- , modificationTimeFieldWith- , teaserField- , teaserFieldWithSeparator- , missingField- ) where------------------------------------------------------------------------------------import Control.Applicative (Alternative (..))-import Control.Monad (msum)-import Data.List (intercalate)-import Data.Time.Clock (UTCTime (..))-import Data.Time.Format (formatTime)-import qualified Data.Time.Format as TF-import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)-import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Core.Provider-import Hakyll.Core.Util.String (needlePrefix, splitAll)-import Hakyll.Web.Html-import System.FilePath (splitDirectories, takeBaseName)-------------------------------------------------------------------------------------- | Mostly for internal usage-data ContextField- = StringField String- | forall a. ListField (Context a) [Item a]-------------------------------------------------------------------------------------- | The 'Context' monoid. Please note that the order in which you--- compose the items is important. For example in------ > field "A" f1 <> field "A" f2------ the first context will overwrite the second. This is especially--- important when something is being composed with--- 'metadataField' (or 'defaultContext'). If you want your context to be--- overwritten by the metadata fields, compose it from the right:------ @--- 'metadataField' \<\> field \"date\" fDate--- @----newtype Context a = Context- { unContext :: String -> [String] -> Item a -> Compiler ContextField- }------------------------------------------------------------------------------------instance Monoid (Context a) where- mempty = missingField- mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i------------------------------------------------------------------------------------field' :: String -> (Item a -> Compiler ContextField) -> Context a-field' key value = Context $ \k _ i -> if k == key then value i else empty-------------------------------------------------------------------------------------- | Constructs a new field in the 'Context.'-field- :: String -- ^ Key- -> (Item a -> Compiler String) -- ^ Function that constructs a value based- -- on the item- -> Context a-field key value = field' key (fmap StringField . value)-------------------------------------------------------------------------------------- | Creates a 'field' to use with the @$if()$@ template macro.-boolField- :: String- -> (Item a -> Bool)- -> Context a-boolField name f = field name (\i -> if f i- then pure (error $ unwords ["no string value for bool field:",name])- else empty)-------------------------------------------------------------------------------------- | Creates a 'field' that does not depend on the 'Item'-constField :: String -> String -> Context a-constField key = field key . const . return------------------------------------------------------------------------------------listField :: String -> Context a -> Compiler [Item a] -> Context b-listField key c xs = listFieldWith key c (const xs)------------------------------------------------------------------------------------listFieldWith- :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b-listFieldWith key c f = field' key $ fmap (ListField c) . f------------------------------------------------------------------------------------functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a-functionField name value = Context $ \k args i ->- if k == name- then StringField <$> value args i- else empty------------------------------------------------------------------------------------mapContext :: (String -> String) -> Context a -> Context a-mapContext f (Context c) = Context $ \k a i -> do- fld <- c k a i- case fld of- StringField str -> return $ StringField (f str)- ListField _ _ -> fail $- "Hakyll.Web.Template.Context.mapContext: " ++- "can't map over a ListField!"------------------------------------------------------------------------------------- | A context that allows snippet inclusion. In processed file, use as:------ > ...--- > $snippet("path/to/snippet/")$--- > ...------ The contents of the included file will not be interpolated.----snippetField :: Context String-snippetField = functionField "snippet" f- where- f [contentsPath] _ = loadBody (fromFilePath contentsPath)- f _ i = error $- "Too many arguments to function 'snippet()' in item " ++- show (itemIdentifier i)------------------------------------------------------------------------------------- | A context that contains (in that order)------ 1. A @$body$@ field------ 2. Metadata fields------ 3. A @$url$@ 'urlField'------ 4. A @$path$@ 'pathField'------ 5. A @$title$@ 'titleField'-defaultContext :: Context String-defaultContext =- bodyField "body" `mappend`- metadataField `mappend`- urlField "url" `mappend`- pathField "path" `mappend`- titleField "title" `mappend`- missingField------------------------------------------------------------------------------------teaserSeparator :: String-teaserSeparator = "<!--more-->"-------------------------------------------------------------------------------------- | Constructs a 'field' that contains the body of the item.-bodyField :: String -> Context String-bodyField key = field key $ return . itemBody-------------------------------------------------------------------------------------- | Map any field to its metadata value, if present-metadataField :: Context a-metadataField = Context $ \k _ i -> do- value <- getMetadataField (itemIdentifier i) k- maybe empty (return . StringField) value-------------------------------------------------------------------------------------- | Absolute url to the resulting item-urlField :: String -> Context a-urlField key = field key $- fmap (maybe empty toUrl) . getRoute . itemIdentifier-------------------------------------------------------------------------------------- | Filepath of the underlying file of the item-pathField :: String -> Context a-pathField key = field key $ return . toFilePath . itemIdentifier-------------------------------------------------------------------------------------- | This title 'field' takes the basename of the underlying file by default-titleField :: String -> Context a-titleField = mapContext takeBaseName . pathField-------------------------------------------------------------------------------------- | When the metadata has a field called @published@ in one of the--- following formats then this function can render the date.------ * @Mon, 06 Sep 2010 00:01:00 +0000@------ * @Mon, 06 Sep 2010 00:01:00 UTC@------ * @Mon, 06 Sep 2010 00:01:00@------ * @2010-09-06T00:01:00+0000@------ * @2010-09-06T00:01:00Z@------ * @2010-09-06T00:01:00@------ * @2010-09-06 00:01:00+0000@------ * @2010-09-06 00:01:00@------ * @September 06, 2010 00:01 AM@------ Following date-only formats are supported too (@00:00:00@ for time is--- assumed)------ * @2010-09-06@------ * @September 06, 2010@------ Alternatively, when the metadata has a field called @path@ in a--- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)--- and no @published@ metadata field set, this function can render--- the date. This pattern matches the file name or directory names--- that begins with @yyyy-mm-dd@ . For example:--- @folder//yyyy-mm-dd-title//dist//main.extension@ .--- In case of multiple matches, the rightmost one is used.--dateField :: String -- ^ Key in which the rendered date should be placed- -> String -- ^ Format to use on the date- -> Context a -- ^ Resulting context-dateField = dateFieldWith defaultTimeLocale-------------------------------------------------------------------------------------- | This is an extended version of 'dateField' that allows you to--- specify a time locale that is used for outputting the date. For more--- details, see 'dateField'.-dateFieldWith :: TimeLocale -- ^ Output time locale- -> String -- ^ Destination key- -> String -- ^ Format to use on the date- -> Context a -- ^ Resulting context-dateFieldWith locale key format = field key $ \i -> do- time <- getItemUTC locale $ itemIdentifier i- return $ formatTime locale format time-------------------------------------------------------------------------------------- | Parser to try to extract and parse the time from the @published@--- field or from the filename. See 'dateField' for more information.--- Exported for user convenience.-getItemUTC :: MonadMetadata m- => TimeLocale -- ^ Output time locale- -> Identifier -- ^ Input page- -> m UTCTime -- ^ Parsed UTCTime-getItemUTC locale id' = do- metadata <- getMetadata id'- let tryField k fmt = lookupString k metadata >>= parseTime' fmt- paths = splitDirectories $ toFilePath id'-- maybe empty' return $ msum $- [tryField "published" fmt | fmt <- formats] ++- [tryField "date" fmt | fmt <- formats] ++- [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]- where- empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++- "could not parse time for " ++ show id'- parseTime' = parseTimeM True locale- formats =- [ "%a, %d %b %Y %H:%M:%S %Z"- , "%Y-%m-%dT%H:%M:%S%Z"- , "%Y-%m-%d %H:%M:%S%Z"- , "%Y-%m-%d"- , "%B %e, %Y %l:%M %p"- , "%B %e, %Y"- , "%b %d, %Y"- ]-------------------------------------------------------------------------------------- | Get the time on which the actual file was last modified. This only works if--- there actually is an underlying file, of couse.-getItemModificationTime- :: Identifier- -> Compiler UTCTime-getItemModificationTime identifier = do- provider <- compilerProvider <$> compilerAsk- return $ resourceModificationTime provider identifier------------------------------------------------------------------------------------modificationTimeField :: String -- ^ Key- -> String -- ^ Format- -> Context a -- ^ Resuting context-modificationTimeField = modificationTimeFieldWith defaultTimeLocale------------------------------------------------------------------------------------modificationTimeFieldWith :: TimeLocale -- ^ Time output locale- -> String -- ^ Key- -> String -- ^ Format- -> Context a -- ^ Resulting context-modificationTimeFieldWith locale key fmt = field key $ \i -> do- mtime <- getItemModificationTime $ itemIdentifier i- return $ formatTime locale fmt mtime-------------------------------------------------------------------------------------- | A context with "teaser" key which contain a teaser of the item.--- The item is loaded from the given snapshot (which should be saved--- in the user code before any templates are applied).-teaserField :: String -- ^ Key to use- -> Snapshot -- ^ Snapshot to load- -> Context String -- ^ Resulting context-teaserField = teaserFieldWithSeparator teaserSeparator-------------------------------------------------------------------------------------- | A context with "teaser" key which contain a teaser of the item, defined as--- the snapshot content before the teaser separator. The item is loaded from the--- given snapshot (which should be saved in the user code before any templates--- are applied).-teaserFieldWithSeparator :: String -- ^ Separator to use- -> String -- ^ Key to use- -> Snapshot -- ^ Snapshot to load- -> Context String -- ^ Resulting context-teaserFieldWithSeparator separator key snapshot = field key $ \item -> do- body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot- case needlePrefix separator body of- Nothing -> fail $- "Hakyll.Web.Template.Context: no teaser defined for " ++- show (itemIdentifier item)- Just t -> return t------------------------------------------------------------------------------------missingField :: Context a-missingField = Context $ \k _ i -> fail $- "Missing field $" ++ k ++ "$ in context for item " ++- show (itemIdentifier i)--parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime-#if MIN_VERSION_time(1,5,0)-parseTimeM = TF.parseTimeM-#else-parseTimeM _ = TF.parseTime-#endif
− src/Hakyll/Web/Template/Internal.hs
@@ -1,221 +0,0 @@------------------------------------------------------------------------------------ | Module containing the template data structure-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Hakyll.Web.Template.Internal- ( Template (..)- , TemplateKey (..)- , TemplateExpr (..)- , TemplateElement (..)- , readTemplate- ) where------------------------------------------------------------------------------------import Control.Applicative ((<|>))-import Control.Monad (void)-import Data.Binary (Binary, get, getWord8, put, putWord8)-import Data.Typeable (Typeable)-import Data.List (intercalate)-import GHC.Exts (IsString (..))-import qualified Text.Parsec as P-import qualified Text.Parsec.String as P------------------------------------------------------------------------------------import Hakyll.Core.Util.Parser-import Hakyll.Core.Writable-------------------------------------------------------------------------------------- | Datatype used for template substitutions.-newtype Template = Template- { unTemplate :: [TemplateElement]- } deriving (Show, Eq, Binary, Typeable)------------------------------------------------------------------------------------instance Writable Template where- -- Writing a template is impossible- write _ _ = return ()------------------------------------------------------------------------------------instance IsString Template where- fromString = readTemplate------------------------------------------------------------------------------------newtype TemplateKey = TemplateKey String- deriving (Binary, Show, Eq, Typeable)------------------------------------------------------------------------------------instance IsString TemplateKey where- fromString = TemplateKey-------------------------------------------------------------------------------------- | Elements of a template.-data TemplateElement- = Chunk String- | Expr TemplateExpr- | Escaped- | If TemplateExpr Template (Maybe Template) -- expr, then, else- | For TemplateExpr Template (Maybe Template) -- expr, body, separator- | Partial TemplateExpr -- filename- deriving (Show, Eq, Typeable)------------------------------------------------------------------------------------instance Binary TemplateElement where- put (Chunk string) = putWord8 0 >> put string- put (Expr e) = putWord8 1 >> put e- put (Escaped) = putWord8 2- put (If e t f ) = putWord8 3 >> put e >> put t >> put f- put (For e b s) = putWord8 4 >> put e >> put b >> put s- put (Partial e) = putWord8 5 >> put e-- get = getWord8 >>= \tag -> case tag of- 0 -> Chunk <$> get- 1 -> Expr <$> get- 2 -> pure Escaped- 3 -> If <$> get <*> get <*> get- 4 -> For <$> get <*> get <*> get- 5 -> Partial <$> get- _ -> error $- "Hakyll.Web.Template.Internal: Error reading cached template"-------------------------------------------------------------------------------------- | Expression in a template-data TemplateExpr- = Ident TemplateKey- | Call TemplateKey [TemplateExpr]- | StringLiteral String- deriving (Eq, Typeable)------------------------------------------------------------------------------------instance Show TemplateExpr where- show (Ident (TemplateKey k)) = k- show (Call (TemplateKey k) as) =- k ++ "(" ++ intercalate ", " (map show as) ++ ")"- show (StringLiteral s) = show s------------------------------------------------------------------------------------instance Binary TemplateExpr where- put (Ident k) = putWord8 0 >> put k- put (Call k as) = putWord8 1 >> put k >> put as- put (StringLiteral s) = putWord8 2 >> put s-- get = getWord8 >>= \tag -> case tag of- 0 -> Ident <$> get- 1 -> Call <$> get <*> get- 2 -> StringLiteral <$> get- _ -> error $- "Hakyll.Web.Tamplte.Internal: Error reading cached template"------------------------------------------------------------------------------------readTemplate :: String -> Template-readTemplate input = case P.parse template "" input of- Left err -> error $ "Cannot parse template: " ++ show err- Right t -> t------------------------------------------------------------------------------------template :: P.Parser Template-template = Template <$>- (P.many $ chunk <|> escaped <|> conditional <|> for <|> partial <|> expr)------------------------------------------------------------------------------------chunk :: P.Parser TemplateElement-chunk = Chunk <$> (P.many1 $ P.noneOf "$")------------------------------------------------------------------------------------expr :: P.Parser TemplateElement-expr = P.try $ do- void $ P.char '$'- e <- expr'- void $ P.char '$'- return $ Expr e------------------------------------------------------------------------------------expr' :: P.Parser TemplateExpr-expr' = stringLiteral <|> call <|> ident------------------------------------------------------------------------------------escaped :: P.Parser TemplateElement-escaped = Escaped <$ (P.try $ P.string "$$")------------------------------------------------------------------------------------conditional :: P.Parser TemplateElement-conditional = P.try $ do- void $ P.string "$if("- e <- expr'- void $ P.string ")$"- thenBranch <- template- elseBranch <- P.optionMaybe $ P.try (P.string "$else$") >> template- void $ P.string "$endif$"- return $ If e thenBranch elseBranch------------------------------------------------------------------------------------for :: P.Parser TemplateElement-for = P.try $ do- void $ P.string "$for("- e <- expr'- void $ P.string ")$"- body <- template- sep <- P.optionMaybe $ P.try (P.string "$sep$") >> template- void $ P.string "$endfor$"- return $ For e body sep------------------------------------------------------------------------------------partial :: P.Parser TemplateElement-partial = P.try $ do- void $ P.string "$partial("- e <- expr'- void $ P.string ")$"- return $ Partial e------------------------------------------------------------------------------------ident :: P.Parser TemplateExpr-ident = P.try $ Ident <$> key------------------------------------------------------------------------------------call :: P.Parser TemplateExpr-call = P.try $ do- f <- key- void $ P.char '('- P.spaces- as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)- P.spaces- void $ P.char ')'- return $ Call f as------------------------------------------------------------------------------------stringLiteral :: P.Parser TemplateExpr-stringLiteral = do- void $ P.char '\"'- str <- P.many $ do- x <- P.noneOf "\""- if x == '\\' then P.anyChar else return x- void $ P.char '\"'- return $ StringLiteral str------------------------------------------------------------------------------------key :: P.Parser TemplateKey-key = TemplateKey <$> metadataKey
− src/Hakyll/Web/Template/List.hs
@@ -1,91 +0,0 @@------------------------------------------------------------------------------------ | Provides an easy way to combine several items in a list. The applications--- are obvious:------ * A post list on a blog------ * An image list in a gallery------ * A sitemap-{-# LANGUAGE TupleSections #-}-module Hakyll.Web.Template.List- ( applyTemplateList- , applyJoinTemplateList- , chronological- , recentFirst- , sortChronological- , sortRecentFirst- ) where------------------------------------------------------------------------------------import Control.Monad (liftM)-import Data.List (intersperse, sortBy)-import Data.Ord (comparing)-import Data.Time.Locale.Compat (defaultTimeLocale)------------------------------------------------------------------------------------import Hakyll.Core.Compiler-import Hakyll.Core.Identifier-import Hakyll.Core.Item-import Hakyll.Core.Metadata-import Hakyll.Web.Template-import Hakyll.Web.Template.Context-------------------------------------------------------------------------------------- | Generate a string of a listing of pages, after applying a template to each--- page.-applyTemplateList :: Template- -> Context a- -> [Item a]- -> Compiler String-applyTemplateList = applyJoinTemplateList ""-------------------------------------------------------------------------------------- | Join a listing of pages with a string in between, after applying a template--- to each page.-applyJoinTemplateList :: String- -> Template- -> Context a- -> [Item a]- -> Compiler String-applyJoinTemplateList delimiter tpl context items = do- items' <- mapM (applyTemplate tpl context) items- return $ concat $ intersperse delimiter $ map itemBody items'-------------------------------------------------------------------------------------- | Sort pages chronologically. Uses the same method as 'dateField' for--- extracting the date.-chronological :: MonadMetadata m => [Item a] -> m [Item a]-chronological =- sortByM $ getItemUTC defaultTimeLocale . itemIdentifier- where- sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]- sortByM f xs = liftM (map fst . sortBy (comparing snd)) $- mapM (\x -> liftM (x,) (f x)) xs-------------------------------------------------------------------------------------- | The reverse of 'chronological'-recentFirst :: MonadMetadata m => [Item a] -> m [Item a]-recentFirst = liftM reverse . chronological-------------------------------------------------------------------------------------- | Version of 'chronological' which doesn't need the actual items.-sortChronological- :: MonadMetadata m => [Identifier] -> m [Identifier]-sortChronological ids =- liftM (map itemIdentifier) $ chronological [Item i () | i <- ids]-------------------------------------------------------------------------------------- | Version of 'recentFirst' which doesn't need the actual items.-sortRecentFirst- :: MonadMetadata m => [Identifier] -> m [Identifier]-sortRecentFirst ids =- liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]
+ src/Init.hs view
@@ -0,0 +1,132 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module Main+ ( main+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow (first)+import Control.Monad (forM, forM_)+import Data.Char (isAlphaNum, isNumber)+import Data.List (intercalate, isPrefixOf)+#if !(MIN_VERSION_base(4,20,0))+import Data.List (foldl')+#endif+import Data.Version (Version (..))+import System.Directory (canonicalizePath, copyFile,+ doesFileExist,+ setPermissions, getPermissions, writable)+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)+import System.FilePath (splitDirectories, (</>))+++--------------------------------------------------------------------------------+import Hakyll.Core.Util.File+import Paths_hakyll+++--------------------------------------------------------------------------------+import Prelude+++--------------------------------------------------------------------------------+main :: IO ()+main = do+ progName <- getProgName+ args <- getArgs+ srcDir <- getDataFileName "example"+ files <- getRecursiveContents (const $ return False) srcDir++ case args of+ -- When the argument begins with hyphens, it's more likely that the user+ -- intends to attempt some arguments like ("--help", "-h", "--version", etc.)+ -- rather than create directory with that name.+ -- If dstDir begins with hyphens, the guard will prevent it from creating+ -- directory with that name so we can fall to the second alternative+ -- which prints a usage info for user.+ [dstDir] | not ("-" `isPrefixOf` dstDir) ->+ createFiles False srcDir files dstDir+ ["-f", dstDir] ->+ createFiles True srcDir files dstDir+ _ -> do+ putStrLn $ "Usage: " ++ progName ++ " [-f] <directory>"+ exitFailure++ where+ createFiles force srcDir files dstDir = do+ name <- makeName dstDir+ let cabalPath = dstDir </> name ++ ".cabal"++ diff <- if force then return []+ else existingFiles dstDir (cabalPath : files)++ case diff of+ [] -> do+ forM_ files $ \file -> do+ let dst = dstDir </> file+ src = srcDir </> file+ putStrLn $ "Creating " ++ dst+ makeDirectories dst+ copyFile src dst+ -- On some systems, the source folder may be readonly,+ -- and copyFile will therefore create a readonly project...+ p <- getPermissions dst+ setPermissions dst (p {writable = True})++ putStrLn $ "Creating " ++ cabalPath+ createCabal cabalPath name+ fs -> do+ putStrLn $ "The following files will be overwritten:"+ mapM_ putStrLn fs+ putStrLn $ "Use -f to overwrite them"+ exitFailure++existingFiles :: FilePath -> [FilePath] -> IO [FilePath]+existingFiles dstDir files = fmap concat $ forM files $ \file -> do+ let dst = dstDir </> file+ exists <- doesFileExist dst+ return $ if exists then [dst] else []++-- | Figure out a good cabal package name from the given (existing) directory+-- name+makeName :: FilePath -> IO String+makeName dstDir = do+ canonical <- canonicalizePath dstDir+ return $ case safeLast (splitDirectories canonical) of+ Nothing -> fallbackName+ Just "/" -> fallbackName+ Just x -> repair (fallbackName ++) id x+ where+ -- Package name repair code comes from+ -- cabal-install.Distribution.Client.Init.Heuristics+ repair invalid valid x = case dropWhile (not . isAlphaNum) x of+ "" -> repairComponent ""+ x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'+ in c ++ repairRest r+ where repairComponent c | all isNumber c = invalid c+ | otherwise = valid c+ repairRest = repair id ('-' :)+ fallbackName = "site"++ safeLast = foldl' (\_ x -> Just x) Nothing++createCabal :: FilePath -> String -> IO ()+createCabal path name =+ writeFile path $ unlines [+ "name: " ++ name+ , "version: 0.1.0.0"+ , "build-type: Simple"+ , "cabal-version: >= 1.10"+ , ""+ , "executable site"+ , " main-is: site.hs"+ , " build-depends: base == 4.*"+ , " , hakyll == " ++ version' ++ ".*"+ , " ghc-options: -threaded -rtsopts -with-rtsopts=-N"+ , " default-language: Haskell2010"+ ]+ where+ -- Major hakyll version+ version' = intercalate "." . take 2 . map show $ versionBranch version
tests/Hakyll/Core/Dependencies/Tests.hs view
@@ -9,8 +9,8 @@ import Data.List (delete) import qualified Data.Map as M import qualified Data.Set as S-import Test.Framework (Test, testGroup)-import Test.HUnit (Assertion, (@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@=?)) --------------------------------------------------------------------------------@@ -20,9 +20,9 @@ ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Dependencies.Tests" $- fromAssertions "analyze" [case01, case02, case03]+ fromAssertions "analyze" [case01, case02, case03, case04, case05] --------------------------------------------------------------------------------@@ -38,11 +38,15 @@ , ("posts/02.md", []) , ("index.md",- [ PatternDependency "posts/*"+ [ contentDependency $ PatternDependency "posts/*" (S.fromList ["posts/01.md", "posts/02.md"])- , IdentifierDependency "posts/01.md"- , IdentifierDependency "posts/02.md"+ , contentDependency $ IdentifierDependency "posts/01.md"+ , contentDependency $ IdentifierDependency "posts/02.md" ])+ , ("sidebar",+ [ metadataDependency $ PatternDependency "posts/*"+ (S.fromList ["posts/01.md", "posts/02.md"])+ ]) ] @@ -51,7 +55,7 @@ case01 :: Assertion case01 = S.fromList ["posts/02.md", "index.md"] @=? ood where- (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts+ (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") S.empty oldFacts --------------------------------------------------------------------------------@@ -59,13 +63,31 @@ case02 :: Assertion case02 = S.singleton "about.md" @=? ood where- (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts+ (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty S.empty oldFacts -------------------------------------------------------------------------------- -- | posts/01.md was removed case03 :: Assertion-case03 = S.singleton "index.md" @=? ood+case03 = S.fromList ["index.md", "sidebar"] @=? ood where (ood, _, _) =- outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts+ outOfDate ("posts/01.md" `delete` oldUniverse) S.empty S.empty oldFacts+++--------------------------------------------------------------------------------+-- | metadata of posts/01.md was changed+case04 :: Assertion+case04 = S.singleton "sidebar" @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse S.empty (S.singleton "posts/01.md") oldFacts+++--------------------------------------------------------------------------------+-- | content of posts/01.md was changed but metadata wasn't+case05 :: Assertion+case05 = S.fromList ["posts/01.md", "index.md"] @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse (S.singleton "posts/01.md") S.empty oldFacts
tests/Hakyll/Core/Identifier/Tests.hs view
@@ -6,47 +6,51 @@ ---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.HUnit ((@=?))+import qualified Test.QuickCheck as Q+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?))+import Test.Tasty.QuickCheck (testProperty) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern+import System.FilePath ((</>), isValid, equalFilePath, pathSeparators) import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests+ , [ testProperty "toFilePath . fromFilePath" filepathConversionProp ] ] ---------------------------------------------------------------------------------captureTests :: [Test]+captureTests :: [TestTree] captureTests = fromAssertions "capture"- [ Just ["bar"] @=? capture "foo/**" "foo/bar"- , Just ["foo/bar"] @=? capture "**" "foo/bar"- , Nothing @=? capture "*" "foo/bar"- , Just [] @=? capture "foo" "foo"- , Just ["foo"] @=? capture "*/bar" "foo/bar"- , Just ["foo/bar"] @=? capture "**/qux" "foo/bar/qux"- , Just ["foo/bar", "qux"] @=? capture "**/*" "foo/bar/qux"- , Just ["foo", "bar/qux"] @=? capture "*/**" "foo/bar/qux"- , Just ["foo"] @=? capture "*.html" "foo.html"- , Nothing @=? capture "*.html" "foo/bar.html"- , Just ["foo/bar"] @=? capture "**.html" "foo/bar.html"- , Just ["foo/bar", "wut"] @=? capture "**/qux/*" "foo/bar/qux/wut"- , Just ["lol", "fun/large"] @=? capture "*cat/**.jpg" "lolcat/fun/large.jpg"- , Just [] @=? capture "\\*.jpg" "*.jpg"- , Nothing @=? capture "\\*.jpg" "foo.jpg"+ [ Just ["bar"] @=? capture "foo/**" "foo/bar"+ , Just ["foo" </> "bar"] @=? capture "**" "foo/bar"+ , Nothing @=? capture "*" "foo/bar"+ , Just [] @=? capture "foo" "foo"+ , Just ["foo"] @=? capture "*/bar" "foo/bar"+ , Just ["foo" </> "bar"] @=? capture "**/qux" "foo/bar/qux"+ , Just ["foo" </> "bar", "qux"] @=? capture "**/*" "foo/bar/qux"+ , Just ["foo", "bar" </> "qux"] @=? capture "*/**" "foo/bar/qux"+ , Just ["foo"] @=? capture "*.html" "foo.html"+ , Nothing @=? capture "*.html" "foo/bar.html"+ , Just ["foo" </> "bar"] @=? capture "**.html" "foo/bar.html"+ , Just ["foo" </> "bar", "wut"] @=? capture "**/qux/*" "foo/bar/qux/wut"+ , Just ["lol", "fun" </> "large"] @=? capture "*cat/**.jpg" "lolcat/fun/large.jpg"+ , Nothing @=? capture "\\*.jpg" "foo.jpg"+ , Just ["xyz","42"] @=? capture (fromRegex "cat-([a-z]+)/foo([0-9]+).jpg") "cat-xyz/foo42.jpg" ] ---------------------------------------------------------------------------------matchesTests :: [Test]+matchesTests :: [TestTree] matchesTests = fromAssertions "matches" [ True @=? matches (fromList ["foo.markdown"]) "foo.markdown" , False @=? matches (fromList ["foo"]) (setVersion (Just "x") "foo")@@ -58,3 +62,16 @@ , True @=? matches ("foo" .||. "bar") "bar" , False @=? matches ("bar" .&&. hasNoVersion) (setVersion (Just "xz") "bar") ]+++--------------------------------------------------------------------------------+-- Ensure that `fromFilePath` and `toFilePath` are inverses of each other (#791)+filepathConversionProp :: Q.Property+filepathConversionProp + = Q.forAll genFilePath + $ \fp -> toFilePath (fromFilePath fp) `equalFilePath` fp+ where+ genFilePath + = Q.listOf1 (Q.elements $ ['a'..'z'] <> pathSeparators) + `Q.suchThat` + isValid
tests/Hakyll/Core/Provider/Metadata/Tests.hs view
@@ -1,22 +1,28 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Hakyll.Core.Provider.Metadata.Tests ( tests ) where ---------------------------------------------------------------------------------import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap import qualified Data.Text as T+#endif import qualified Data.Yaml as Yaml import Hakyll.Core.Metadata import Hakyll.Core.Provider.Metadata-import Test.Framework (Test, testGroup)-import Test.HUnit (Assertion, (@=?), assertFailure)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, (@=?)) import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Provider.Metadata.Tests" $ fromAssertions "page" [testPage01, testPage02] @@ -26,10 +32,7 @@ testPage01 :: Assertion testPage01 = (meta [("foo", "bar")], "qux\n") `expectRight` parsePage- "---\n\- \foo: bar\n\- \---\n\- \qux\n"+ "---\nfoo: bar\n---\nqux\n" --------------------------------------------------------------------------------@@ -37,21 +40,22 @@ testPage02 = (meta [("description", descr)], "Hello I am dog\n") `expectRight` parsePage- "---\n\- \description: A long description that would look better if it\n\- \ spanned multiple lines and was indented\n\- \---\n\- \Hello I am dog\n"+ "---\ndescription: A long description that would look better if it\n spanned multiple lines and was indented\n---\nHello I am dog\n" where descr :: String descr =- "A long description that would look better if it \- \spanned multiple lines and was indented"+ "A long description that would look better if it spanned multiple lines and was indented" -------------------------------------------------------------------------------- meta :: Yaml.ToJSON a => [(String, a)] -> Metadata-meta pairs = HMS.fromList [(T.pack k, Yaml.toJSON v) | (k, v) <- pairs]+meta pairs = KeyMap.fromList [(keyFromString k, Yaml.toJSON v) | (k, v) <- pairs]+ where+#if MIN_VERSION_aeson(2,0,0)+ keyFromString = AK.fromString+#else+ keyFromString = T.pack+#endif --------------------------------------------------------------------------------
tests/Hakyll/Core/Provider/Tests.hs view
@@ -8,14 +8,13 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Metadata import Hakyll.Core.Provider-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assert, (@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@=?)) import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Provider.Tests" [ testCase "case01" case01 ]@@ -26,7 +25,7 @@ case01 = do store <- newTestStore provider <- newTestProvider store- assert $ resourceExists provider "example.md"+ True @=? resourceExists provider "example.md" metadata <- resourceMetadata provider "example.md" Just "An example" @=? lookupString "title" metadata
tests/Hakyll/Core/Routes/Tests.hs view
@@ -10,14 +10,14 @@ import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Routes-import System.FilePath ((</>))-import Test.Framework (Test, testGroup)-import Test.HUnit (Assertion, (@=?))+import System.FilePath ((</>), normalise)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes" [ testRoutes "foo.html" (setExtension "html") "foo" , testRoutes "foo.html" (setExtension ".html") "foo"@@ -46,5 +46,5 @@ store <- newTestStore provider <- newTestProvider store (route, _) <- runRoutes r provider id'- Just expected @=? route+ Just (normalise expected) @=? route cleanTestEnv
tests/Hakyll/Core/Rules/Tests.hs view
@@ -17,15 +17,14 @@ import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal-import Hakyll.Web.Pandoc-import System.FilePath ((</>))-import Test.Framework (Test, testGroup)-import Test.HUnit (Assertion, assert, (@=?))+import System.FilePath ((</>), normalise)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Rules.Tests" $ fromAssertions "runRules" [case01] @@ -40,7 +39,7 @@ let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet routes = rulesRoutes ruleSet checkRoute ex i =- runRoutes routes provider i >>= \(r, _) -> Just ex @=? r+ runRoutes routes provider i >>= \(r, _) -> Just (normalise ex) @=? r -- Test that we have some identifiers and that the routes work out S.fromList expected @=? identifiers@@ -50,7 +49,7 @@ checkRoute "example.mv1" (sv "mv1" "example.md") checkRoute "example.mv2" (sv "mv2" "example.md") checkRoute "food/example.md" (sv "metadataMatch" "example.md")- readIORef ioref >>= assert+ readIORef ioref >>= (True @=?) cleanTestEnv where sv g = setVersion (Just g)@@ -75,7 +74,7 @@ -- Compile some posts match "*.md" $ do route $ setExtension "html"- compile pandocCompiler+ compile copyFileCompiler -- Yeah. I don't know how else to test this stuff? preprocess $ writeIORef ioref True
tests/Hakyll/Core/Runtime/Tests.hs view
@@ -6,10 +6,13 @@ --------------------------------------------------------------------------------+import Control.Monad (void) import qualified Data.ByteString as B+import Data.List (isInfixOf)+import System.Exit (ExitCode (..)) import System.FilePath ((</>))-import Test.Framework (Test, testGroup)-import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) --------------------------------------------------------------------------------@@ -20,16 +23,24 @@ ---------------------------------------------------------------------------------tests :: Test-tests = testGroup "Hakyll.Core.Runtime.Tests" $- fromAssertions "run" [case01, case02]+tests :: TestTree+tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run"+ [ case01+ , case02+ , case03+ , case04+ , case05+ , case06+ , issue1000+ , issue1014+ ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/*" $ do route idRoute compile copyFileCompiler@@ -39,8 +50,17 @@ compile $ do getResourceBody >>= saveSnapshot "raw"- >>= renderPandoc+ >>= renderParagraphs + match (fromList ["partial.html", "partial-helper.html"]) $+ compile templateCompiler+ create ["partial.html.out"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "example.md" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext+ create ["bodies.txt"] $ do route idRoute compile $ do@@ -58,16 +78,24 @@ lines example @?= ["<p>This is an example.</p>"] bodies <- readFile $ destinationDirectory testConfiguration </> "bodies.txt"- head (lines bodies) @?= "This is an example."+ head' (lines bodies) @?= "This is an example." + partial <- readFile $ providerDirectory testConfiguration </> "partial.html.out"+ partial' <- readFile $ destinationDirectory testConfiguration </> "partial.html.out"+ partial @?= partial'+ cleanTestEnv + where+ head' (x:_) = x+ head' [] = error "Hakyll.Core.Runtime.Tests.case01: impossible" + -------------------------------------------------------------------------------- case02 :: Assertion case02 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/favicon.ico" $ do route $ gsubRoute "images/" (const "") compile $ makeItem ("Test" :: String)@@ -80,4 +108,183 @@ destinationDirectory testConfiguration </> "favicon.ico" favicon @?= "Test" + cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified+case03 :: Assertion+case03 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out2"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out1"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified when snapshots+-- are also involved. See issue #878.+case04 :: Assertion+case04 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out2" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out1" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. See issue #878.+case05 :: Assertion+case05 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ match "posts/*" $ do+ route $ setExtension "html"+ compile $ do+ let applyDefaultTemplate item = do+ footer <- loadBody "footer.html"+ let postCtx' =+ constField "footer" footer `mappend`+ defaultContext+ loadAndApplyTemplate "template-empty.html" postCtx' item++ pandocCompiler+ >>= saveSnapshot "content"+ >>= loadAndApplyTemplate "template-empty.html" defaultContext+ >>= applyDefaultTemplate+ >>= relativizeUrls++ create ["footer.html"] $+ compile $ do+ posts <- fmap (take 5) . recentFirst =<< loadAllSnapshots "posts/*" "content"+ let footerCtx =+ listField "posts" defaultContext (return posts) `mappend`+ defaultContext++ makeItem ""+ >>= loadAndApplyTemplate "template-empty.html" footerCtx++ create ["template-empty.html"] $ compile templateCompiler++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. The test case below was presented as an example which invalidated+-- a previous approach to dependency cycle checking.+-- See https://github.com/jaspervdj/hakyll/pull/880#discussion_r708650172+case06 :: Assertion+case06 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["one.html"] $ do+ route idRoute+ compile $ do+ void $ makeItem ("one-one" :: String) >>= saveSnapshot "one"+ _ <- loadSnapshotBody "two.html" "two" :: Compiler String+ void $ makeItem ("one-three" :: String) >>= saveSnapshot "three"+ makeItem ("one-two" :: String) >>= saveSnapshot "two"++ create ["two.html"] $ do+ route idRoute+ compile $ do+ _ <- loadSnapshotBody "one.html" "one" :: Compiler String+ void $ makeItem ("two-two" :: String) >>= saveSnapshot "two"+ text <- loadSnapshotBody "one.html" "two"+ makeItem (text :: String)++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1000 :: Assertion+issue1000 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ compile getResourceBody+ match "*.md" $ version "nav" $ do+ route $ setExtension "html"+ compile $ getResourceBody >>= traverse (pure . reverse)++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'multiple writes' errors" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "multiple writes" `isInfixOf` msg+ ]++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1014 :: Assertion+issue1014 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ -- This compiler will succeed due to laziness, but writing the+ -- result will throw an exception.+ compile $ makeItem ("hello" ++ error "lazyworld")++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'lazyworld' error" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "lazyworld" `isInfixOf` msg+ ]+ assertBool "unwanted 'Success' message" $ not $+ (Logger.Message, "Success") `elem` msgs cleanTestEnv
tests/Hakyll/Core/Store/Tests.hs view
@@ -6,22 +6,22 @@ ---------------------------------------------------------------------------------import Data.Typeable (typeOf)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import qualified Test.HUnit as H-import qualified Test.QuickCheck as Q-import qualified Test.QuickCheck.Monadic as Q+import Data.Typeable (typeOf)+import qualified Test.QuickCheck as Q+import qualified Test.QuickCheck.Monadic as Q+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import qualified Test.Tasty.HUnit as H+import Test.Tasty.QuickCheck (testProperty) ---------------------------------------------------------------------------------import qualified Hakyll.Core.Store as Store+import qualified Hakyll.Core.Store as Store import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Store.Tests" [ testProperty "simple get . set" simpleSetGet , testProperty "persistent get . set" persistentSetGet@@ -63,11 +63,11 @@ -- Store a string and try to fetch an int Store.set store ["foo", "bar"] ("qux" :: String) value <- Store.get store ["foo", "bar"] :: IO (Store.Result Int)- H.assert $ case value of- Store.WrongType e t ->- e == typeOf (undefined :: Int) &&- t == typeOf (undefined :: String)- _ -> False+ case value of+ Store.WrongType e t -> do+ typeOf (undefined :: Int) H.@=? e+ typeOf (undefined :: String) H.@=? t+ _ -> H.assertFailure "Expecting WrongType" cleanTestEnv @@ -78,6 +78,6 @@ Store.set store ["foo", "bar"] ("qux" :: String) good <- Store.isMember store ["foo", "bar"] bad <- Store.isMember store ["foo", "baz"]- H.assert good- H.assert (not bad)+ True H.@=? good+ False H.@=? bad cleanTestEnv
tests/Hakyll/Core/UnixFilter/Tests.hs view
@@ -1,45 +1,55 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Hakyll.Core.UnixFilter.Tests ( tests ) where ---------------------------------------------------------------------------------import Data.List (isInfixOf)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import qualified Test.HUnit as H+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import qualified Test.Tasty.HUnit as H -------------------------------------------------------------------------------- import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.UnixFilter import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test-tests = testGroup "Hakyll.Core.UnixFilter.Tests"- [ testCase "unixFilter rev" unixFilterRev- , testCase "unixFilter false" unixFilterFalse+tests :: TestTree+tests = testGroup "Hakyll.Core.UnixFilter.Tests" $+#ifdef mingw32_HOST_OS+ [] -- The `rev` utility is not present by default on Windows+#else+ [ testCase "unixFilter rev" unixFilterRev ]+#endif+ +++ [ testCase "unixFilter false" unixFilterFalse+ , testCase "unixFilter error" unixFilterError ] +testMarkdown :: Identifier+testMarkdown = "russian.md" --------------------------------------------------------------------------------+#ifndef mingw32_HOST_OS unixFilterRev :: H.Assertion unixFilterRev = do store <- newTestStore provider <- newTestProvider store- output <- testCompilerDone store provider "russian.md" compiler- expected <- testCompilerDone store provider "russian.md" getResourceString- H.assert $ rev (itemBody expected) == lines (itemBody output)+ output <- testCompilerDone store provider testMarkdown compiler+ expected <- testCompilerDone store provider testMarkdown getResourceString+ rev (itemBody expected) H.@=? lines (itemBody output) cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "rev" []) rev = map reverse . lines+#endif --------------------------------------------------------------------------------@@ -47,10 +57,18 @@ unixFilterFalse = do store <- newTestStore provider <- newTestProvider store- result <- testCompiler store provider "russian.md" compiler- H.assert $ case result of- CompilerError es -> any ("exit code" `isInfixOf`) es- _ -> False+ testCompilerError store provider testMarkdown compiler "exit code" cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "false" [])+++--------------------------------------------------------------------------------+unixFilterError :: H.Assertion+unixFilterError = do+ store <- newTestStore+ provider <- newTestProvider store+ testCompilerError store provider testMarkdown compiler "option"+ cleanTestEnv+ where+ compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"])
tests/Hakyll/Core/Util/String/Tests.hs view
@@ -5,8 +5,8 @@ ---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.HUnit ((@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?)) --------------------------------------------------------------------------------@@ -15,18 +15,30 @@ ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Core.Util.String.Tests" $ concat [ fromAssertions "trim" [ "foo" @=? trim " foo\n\t " ] , fromAssertions "replaceAll"- [ "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83"+ [ "foo-end" @=? replaceAll "begin" (const "foo") "begin-end"+ , "begin-foo" @=? replaceAll "end" (const "foo") "begin-end"+ , "no match" @=? replaceAll "abc" (const "foo") "no match"+ , "foo" @=? replaceAll ".*" (const "foo") "full match"+ , "empty pattern" @=? replaceAll "" (const "foo") "empty pattern"+ , "" @=? replaceAll "empty input" (const "foo") ""+ , "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83" ] , fromAssertions "splitAll"- [ ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi"+ [ ["a", "b", "c"] @=? splitAll "," "a,,b,,,c,,"+ , ["abc", "def"] @=? splitAll "[0-9]+" "abc123def456"+ , ["no match"] @=? splitAll "," "no match"+ , [] @=? splitAll ".*" "full match"+ , ["empty pattern"] @=? splitAll "" "empty pattern"+ , [] @=? splitAll "empty input" ""+ , ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi" ] , fromAssertions "needlePrefix"
+ tests/Hakyll/Web/CompressCss/Tests.hs view
@@ -0,0 +1,66 @@+--------------------------------------------------------------------------------+module Hakyll.Web.CompressCss.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?))+++--------------------------------------------------------------------------------+import Hakyll.Web.CompressCss+import TestSuite.Util+++--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.CompressCss.Tests" $ concat+ [ fromAssertions "compressCss"+ [+ -- compress whitespace+ "something something" @=?+ compressCss " something \n\t\r something "+ -- do not compress whitespace in string tokens+ , "abc \" \t\n\r \" xyz" @=?+ compressCss "abc \" \t\n\r \" xyz"+ , "abc ' \t\n\r ' xyz" @=?+ compressCss "abc ' \t\n\r ' xyz"++ -- strip comments+ , "before after" @=? compressCss "before /* abc { } ;; \n\t\r */ after"+ -- don't strip comments inside string tokens+ , "before \"/* abc { } ;; \n\t\r */\" after"+ @=? compressCss "before \"/* abc { } ;; \n\t\r */\" after"++ -- compress separators+ , "}" @=? compressCss "; }"+ , ";{};" @=? compressCss " ; { } ; "+ , "text," @=? compressCss "text , "+ , "a>b" @=? compressCss "a > b"+ , "a+b" @=? compressCss "a + b"+ , "a!b" @=? compressCss "a ! b"+ -- compress calc()+ , "calc(1px + 100%/(5 + 3) - (3px + 2px)*5)" @=? compressCss "calc( 1px + 100% / ( 5 + 3) - calc( 3px + 2px ) * 5 )"+ -- compress clamp() (issue #1021)+ , "clamp(2.25rem, 2vw + 1.5rem, 3.25rem)" @=? compressCss "clamp(2.25rem, 2vw + 1.5rem, 3.25rem)"+ -- compress whitespace even after this curly brace+ , "}" @=? compressCss "; } "+ -- but do not compress separators inside string tokens+ , "\" { } ; , \"" @=? compressCss "\" { } ; , \""+ -- don't compress separators at the start or end of string tokens+ , "\" }\"" @=? compressCss "\" }\""+ , "\"{ \"" @=? compressCss "\"{ \""+ -- don't get irritated by the wrong token delimiter+ , "\" ' \"" @=? compressCss "\" ' \""+ , "' \" '" @=? compressCss "' \" '"+ -- don't compress whitespace in the middle of a string+ , "abc '{ '" @=? compressCss "abc '{ '"+ , "abc \"{ \"" @=? compressCss "abc \"{ \""+ -- compress whitespace after colons (but not before)+ , "abc :xyz" @=? compressCss "abc : xyz"+ -- compress multiple semicolons+ , ";" @=? compressCss ";;;;;;;"+ ]+ ]
+ tests/Hakyll/Web/Feed/Tests.hs view
@@ -0,0 +1,68 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Feed.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Provider+import Hakyll.Web.Feed+import Hakyll.Web.Template.Context+import TestSuite.Util+--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Feed.Tests"+ [ testCase "validateSucceeds" validateSucceeds+ , testCase "validateFails" validateFails+ ]++validateFails :: Assertion+validateFails = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ testCompilerError store provider "feed.xml"+ (renderRss feedConfiguration ctx [item])+ "Generated feed contains invalid XML (perhaps you id not escape a metadata field?)"+ cleanTestEnv+ where+ title = "invalid & not xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++validateSucceeds :: Assertion+validateSucceeds = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ _ <- testCompilerDone store provider "feed.xml"+ $ renderRss feedConfiguration ctx [item]+ cleanTestEnv+ where+ title = "valid xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++feedConfiguration :: FeedConfiguration+feedConfiguration = FeedConfiguration+ { feedTitle = "test"+ , feedDescription = "test"+ , feedAuthorName = "test"+ , feedAuthorEmail = ""+ , feedRoot = "example.org"+ }
tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs view
@@ -6,16 +6,17 @@ ---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.HUnit ((@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?)) + -------------------------------------------------------------------------------- import Hakyll.Web.Html.RelativizeUrls import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Web.Html.RelativizeUrls.Tests" $ fromAssertions "relativizeUrls" [ "<a href=\"../foo\">bar</a>" @=?@@ -34,4 +35,6 @@ , "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>" @=? relativizeUrlsWith "../.." "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>"+ , "<img srcset=\"./image.png 200w, ./image2.png 400w\" />" @=?+ relativizeUrlsWith "." "<img srcset=\"/image.png 200w, /image2.png 400w\" />" ]
tests/Hakyll/Web/Html/Tests.hs view
@@ -5,9 +5,10 @@ ---------------------------------------------------------------------------------import Data.Char (toUpper)-import Test.Framework (Test, testGroup)-import Test.HUnit (assert, (@=?))+import Data.Char (toUpper)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?))+import qualified Text.HTML.TagSoup as TS --------------------------------------------------------------------------------@@ -16,13 +17,41 @@ ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "<h2>A h1 title</h2>" @=?- demoteHeaders "<h1>A h1 title</h1>"+ demoteHeaders "<h1>A h1 title</h1>" -- Assert single-step demotion+ , "<h6>A h6 title</h6>" @=?+ demoteHeaders "<h6>A h6 title</h6>" -- Assert maximum demotion is h6 ] + , fromAssertions "demoteHeadersBy"+ [ "<h3>A h1 title</h3>" @=?+ demoteHeadersBy 2 "<h1>A h1 title</h1>"+ , "<h6>A h5 title</h6>" @=?+ demoteHeadersBy 2 "<h5>A h5 title</h5>" -- Assert that h6 is the lowest possible demoted header.+ , "<h4>A h4 title</h4>" @=?+ demoteHeadersBy 0 "<h4>A h4 title</h4>" -- Assert that a demotion of @N < 1@ is a no-op.+ ]++ , fromAssertions "getUrls"+ [ ["/image1.png", "/image2.jpeg", "https://example.com", "/game.swf", "/poster.jpeg"] @=?+ getUrls [+ TS.TagOpen "img" [("src", "/image1.png")]+ , TS.TagOpen "img" [("src", "/image2.jpeg")]+ , TS.TagOpen "a" [("href", "https://example.com")]+ , TS.TagOpen "object" [("data", "/game.swf")]+ , TS.TagOpen "video" [("poster", "/poster.jpeg")]+ ]+ , ["/image1.png", "/image2.jpeg", "/image3.bmp"] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10w, /image2.jpeg, /image3.bmp 1.3x")] ]++ -- Invalid srcset specification means no URLs are extracted+ , [] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10wide, /image2.jpeg, /image3.bmp 1.3px")] ]+ ]+ , fromAssertions "withUrls" [ "<a href=\"FOO\">bar</a>" @=? withUrls (map toUpper) "<a href=\"foo\">bar</a>"@@ -40,10 +69,21 @@ -- Test minimizing elements , "<meta bar=\"foo\" />" @=? withUrls id "<meta bar=\"foo\" />"++ -- Test that URLs are extracted from img's srcset+ , "<img srcset=\"foo 200w\" />" @=?+ withUrls (const "foo") "<img srcset=\"/path/to/image.png 200w\" />"+ , "<img srcset=\"bar 200w, bar 400w\" />" @=?+ withUrls (const "bar") "<img srcset=\"/small.jpeg 200w, /img/large.jpeg 400w\" />"++ -- Invalid srcsets are left unchanged+ , "<img srcset=\"/image1.png 200px\" />" @=?+ withUrls (const "bar") "<img srcset=\"/image1.png 200px\" />" ] , fromAssertions "toUrl" [ "/foo/bar.html" @=? toUrl "foo/bar.html"+ , "/foo/bar.html" @=? toUrl "foo\\bar.html" -- Windows-specific , "/" @=? toUrl "/" , "/funny-pics.html" @=? toUrl "/funny-pics.html" , "/funny%20pics.html" @=? toUrl "funny pics.html"@@ -64,11 +104,11 @@ ] , fromAssertions "isExternal"- [ assert (isExternal "http://reddit.com")- , assert (isExternal "https://mail.google.com")- , assert (isExternal "//ajax.googleapis.com")- , assert (not (isExternal "../header.png"))- , assert (not (isExternal "/foo/index.html"))+ [ True @=? isExternal "http://reddit.com"+ , True @=? isExternal "https://mail.google.com"+ , True @=? isExternal "//ajax.googleapis.com"+ , False @=? isExternal "../header.png"+ , False @=? isExternal "/foo/index.html" ] , fromAssertions "stripTags"
+ tests/Hakyll/Web/Pandoc/Biblio/Tests.hs view
@@ -0,0 +1,164 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Hakyll.Web.Pandoc.Biblio.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS+++--------------------------------------------------------------------------------+import Hakyll+import Hakyll.Core.Runtime+import qualified Hakyll.Core.Logger as Logger+import TestSuite.Util+++--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Pandoc.Biblio.Tests" $+ [ goldenTest01+ , goldenTest02+ , goldenTest03+ ]++--------------------------------------------------------------------------------+goldenTestsDataDir :: FilePath+goldenTestsDataDir = "tests/data/biblio"++--------------------------------------------------------------------------------+goldenTest01 :: TestTree+goldenTest01 =+ goldenVsString+ "biblio01"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.bib"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)++ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest02 :: TestTree+goldenTest02 =+ goldenVsString+ "biblio02"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.yaml"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.yaml" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest03 :: TestTree+goldenTest03 =+ goldenVsString+ "biblio03"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib1 <- load "refs.bib"+ bib2 <- load "refs2.yaml"+ getResourceBody >>=+ readPandocBiblios defaultHakyllReaderOptions csl [bib1, bib2] >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "refs2.yaml" $ compile biblioCompiler+ match "cites-multiple.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "cites-multiple.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-multiple-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-multiple-pandoc-3.0.0plus.golden"+#else+ "cites-multiple-pandoc-2.0.0plus.golden"+#endif
tests/Hakyll/Web/Pandoc/FileType/Tests.hs view
@@ -6,8 +6,8 @@ ---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.HUnit ((@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?)) --------------------------------------------------------------------------------@@ -16,10 +16,11 @@ ---------------------------------------------------------------------------------tests :: Test+tests :: TestTree tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $ fromAssertions "fileType"- [ Markdown @=? fileType "index.md"+ [ Jupyter @=? fileType "index.ipynb"+ , Markdown @=? fileType "index.md" , Rst @=? fileType "about/foo.rst" , LiterateHaskell Markdown @=? fileType "posts/bananas.lhs" , LiterateHaskell LaTeX @=? fileType "posts/bananas.tex.lhs"
+ tests/Hakyll/Web/Tags/Tests.hs view
@@ -0,0 +1,42 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Tags.Tests+ ( tests+ ) where++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Provider+import Hakyll.Core.Store (Store)+import Hakyll.Web.Tags+import TestSuite.Util++tests :: TestTree+tests = testGroup "Hakyll.Web.Tags"+ [ testCase "testGetCategory" testGetCategory+ ]++testGetCategory :: Assertion+testGetCategory = do+ store <- newTestStore+ provider <- newTestProvider store++ noCategory <- testCategoryDone store provider "example.md"+ noCategory @?= [""]++ oneCategory1 <- testCategoryDone store provider "posts/2010-08-26-birthday.md"+ oneCategory1 @?= ["posts"]++ oneCategory2 <- testCategoryDone store provider "posts/2019/05/10/tomorrow.md"+ oneCategory2 @?= ["10"]++ cleanTestEnv++--------------------------------------------------------------------------------+testCategoryDone :: Store -> Provider -> Identifier -> IO [String]+testCategoryDone store provider identifier =+ testCompilerDone store provider identifier $ getCategory identifier
tests/Hakyll/Web/Template/Context/Tests.hs view
@@ -6,23 +6,22 @@ ---------------------------------------------------------------------------------import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, (@=?))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Provider-import Hakyll.Core.Store (Store)+import Hakyll.Core.Store (Store) import Hakyll.Web.Template.Context import TestSuite.Util ---------------------------------------------------------------------------------tests :: Test-tests = testGroup "Hakyll.Core.Template.Context.Tests"+tests :: TestTree+tests = testGroup "Hakyll.Web.Template.Context.Tests" [ testCase "testDateField" testDateField ] @@ -42,6 +41,15 @@ dateField "date" "%B %e, %Y" date2 @=? "August 26, 2010" + date3 <- testContextDone store provider+ "posts/2018-09-26.md" "date" $+ dateField "date" "%B %e, %Y"+ date3 @=? "September 26, 2018"++ date4 <- testContextDone store provider+ "posts/2019/05/10/tomorrow.md" "date" $+ dateField "date" "%B %e, %Y"+ date4 @=? "May 10, 2019" cleanTestEnv @@ -54,6 +62,6 @@ cf <- unContext context key [] item case cf of StringField str -> return str- ListField _ _ -> error $+ _ -> error $ "Hakyll.Web.Template.Context.Tests.testContextDone: " ++- "Didn't expect ListField"+ "expected StringField"
tests/Hakyll/Web/Template/Tests.hs view
@@ -1,22 +1,24 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Hakyll.Web.Template.Tests ( tests ) where ---------------------------------------------------------------------------------import Data.Monoid (mconcat)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, (@=?), (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, testCase,+ (@=?), (@?=)) +import Data.Either (isLeft)+import System.IO (nativeNewline, Newline(..)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler+import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Provider-import Hakyll.Web.Pandoc import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal@@ -25,35 +27,83 @@ ---------------------------------------------------------------------------------tests :: Test-tests = testGroup "Hakyll.Core.Template.Tests" $ concat- [ [ testCase "case01" case01+tests :: TestTree+tests = testGroup "Hakyll.Web.Template.Tests" $ concat+ [ [ testCase "case01" $ test ("template.html.out", "template.html", "example.md")+ , testCase "case02" $ test ("strip.html.out", "strip.html", "example.md")+ , testCase "case03" $ test ("just-meta.html.out", "just-meta.html", "example.md") , testCase "applyJoinTemplateList" testApplyJoinTemplateList ] - , fromAssertions "readTemplate"- [ Template [Chunk "Hello ", Expr (Call "guest" [])]- @=? readTemplate "Hello $guest()$"- , Template- [If (Call "a" [StringLiteral "bar"])- (Template [Chunk "foo"])- Nothing]- @=? readTemplate "$if(a(\"bar\"))$foo$endif$"+ , fromAssertions "parseTemplate"+ [ Right [Chunk "Hello ", Expr (Call "guest" [])]+ @=? parse "Hello $guest()$"+ , Right [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]+ @=? parse "$if(a(\"bar\"))$foo$endif$"+ -- 'If' trim check.+ , Right [ TrimL+ , If (Ident (TemplateKey "body"))+ [ TrimR+ , Chunk "\n"+ , Expr (Ident (TemplateKey "body"))+ , Chunk "\n"+ , TrimL+ ]+ (Just [ TrimR+ , Chunk "\n"+ , Expr (Ident (TemplateKey "body"))+ , Chunk "\n"+ , TrimL+ ])+ , TrimR+ ]+ @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"+ -- 'For' trim check.+ , Right [ TrimL+ , For (Ident (TemplateKey "authors"))+ [TrimR, Chunk "\n body \n", TrimL]+ Nothing+ , TrimR+ ]+ @=? parse "$-for(authors)-$\n body \n$-endfor-$"+ -- 'Partial' trim check.+ , Right [ TrimL+ , Partial (StringLiteral "path")+ , TrimR+ ]+ @=? parse "$-partial(\"path\")-$"+ -- 'Expr' trim check.+ , Right [ TrimL+ , Expr (Ident (TemplateKey "foo"))+ , TrimR+ ]+ @=? parse "$-foo-$"+ -- fail on incomplete template.+ , assertBool "did not yield error" $ isLeft $+ parse "a$b"+ -- fail on mismatched template syntax.+ , assertBool "did not fail to parse" $ isLeft $+ parse "$for(xs)$\n <p>foo</p>\n$endif$" ]++ , [testCase "embeddedTemplate" testEmbeddedTemplate] ]+ where+ parse = parseTemplateElemsFile "" ---------------------------------------------------------------------------------case01 :: Assertion-case01 = do+test :: (Identifier, Identifier, Identifier) -> Assertion+test (outf, tplf, itemf) = do store <- newTestStore provider <- newTestProvider store - out <- resourceString provider "template.html.out"- tpl <- testCompilerDone store provider "template.html" $- templateBodyCompiler- item <- testCompilerDone store provider "example.md" $- pandocCompiler >>= applyTemplate (itemBody tpl) testContext+ out <- resourceString provider outf+ tpl <- testCompilerDone store provider tplf templateBodyCompiler+ item <- testCompilerDone store provider itemf $+ getResourceBody+ >>= renderParagraphs+ >>= applyTemplate (itemBody tpl) testContext out @=? itemBody item cleanTestEnv@@ -69,7 +119,6 @@ return [n1, n2] , functionField "rev" $ \args _ -> return $ unwords $ map reverse args ]- where --------------------------------------------------------------------------------@@ -77,6 +126,8 @@ testApplyJoinTemplateList = do store <- newTestStore provider <- newTestProvider store+ tpl <- testCompilerDone store provider "tpl" $+ compileTemplateItem (Item "tpl" "<b>$body$</b>") str <- testCompilerDone store provider "item3" $ applyJoinTemplateList ", " tpl defaultContext [i1, i2] @@ -85,4 +136,25 @@ where i1 = Item "item1" "Hello" i2 = Item "item2" "World"- tpl = Template [Chunk "<b>", Expr (Ident "body"), Chunk "</b>"]+++--------------------------------------------------------------------------------+embeddedTemplate :: Template+embeddedTemplate = $(embedTemplate "tests/data/embed.html")++--------------------------------------------------------------------------------+testEmbeddedTemplate :: Assertion+testEmbeddedTemplate = do+ store <- newTestStore+ provider <- newTestProvider store+ str <- testCompilerDone store provider "item3" $+ applyTemplate embeddedTemplate defaultContext item++ itemBody str @?= ("<p>Hello, world</p>" ++ (newline nativeNewline))+ cleanTestEnv+ where+ item = Item "item1" "Hello, world"+ + newline LF = "\n"+ newline CRLF = "\r\n"+
tests/TestSuite.hs view
@@ -1,11 +1,12 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Main ( main ) where ---------------------------------------------------------------------------------import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) --------------------------------------------------------------------------------@@ -19,16 +20,22 @@ import qualified Hakyll.Core.Store.Tests import qualified Hakyll.Core.UnixFilter.Tests import qualified Hakyll.Core.Util.String.Tests+import qualified Hakyll.Web.CompressCss.Tests import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests+#ifdef USE_PANDOC+import qualified Hakyll.Web.Pandoc.Biblio.Tests import qualified Hakyll.Web.Pandoc.FileType.Tests+#endif import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests+import qualified Hakyll.Web.Tags.Tests+import qualified Hakyll.Web.Feed.Tests -------------------------------------------------------------------------------- main :: IO ()-main = defaultMain+main = defaultMain $ testGroup "Hakyll" [ Hakyll.Core.Dependencies.Tests.tests , Hakyll.Core.Identifier.Tests.tests , Hakyll.Core.Provider.Metadata.Tests.tests@@ -39,9 +46,15 @@ , Hakyll.Core.Store.Tests.tests , Hakyll.Core.UnixFilter.Tests.tests , Hakyll.Core.Util.String.Tests.tests+ , Hakyll.Web.CompressCss.Tests.tests , Hakyll.Web.Html.RelativizeUrls.Tests.tests , Hakyll.Web.Html.Tests.tests+#ifdef USE_PANDOC+ , Hakyll.Web.Pandoc.Biblio.Tests.tests , Hakyll.Web.Pandoc.FileType.Tests.tests+#endif+ , Hakyll.Web.Tags.Tests.tests , Hakyll.Web.Template.Context.Tests.tests , Hakyll.Web.Template.Tests.tests+ , Hakyll.Web.Feed.Tests.tests ]
tests/TestSuite/Util.hs view
@@ -6,38 +6,39 @@ , newTestProvider , testCompiler , testCompilerDone+ , testCompilerError , testConfiguration , cleanTestEnv+ , renderParagraphs ) where ---------------------------------------------------------------------------------import Data.List (intercalate)-import Data.Monoid (mempty)-import qualified Data.Set as S-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)-import Text.Printf (printf)+import Data.List (intercalate, isInfixOf)+import qualified Data.Set as S+import Test.Tasty+import Test.Tasty.HUnit+import Text.Printf (printf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Configuration import Hakyll.Core.Identifier-import qualified Hakyll.Core.Logger as Logger+import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Provider-import Hakyll.Core.Store (Store)-import qualified Hakyll.Core.Store as Store+import Hakyll.Core.Store (Store)+import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File+import Hakyll.Core.Item -------------------------------------------------------------------------------- fromAssertions :: String -- ^ Name -> [Assertion] -- ^ Cases- -> [Test] -- ^ Result tests+ -> [TestTree] -- ^ Result tests fromAssertions name =- zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]]+ zipWith testCase [printf "%02d_%s" n name | n <- [1 :: Int ..]] --------------------------------------------------------------------------------@@ -47,8 +48,10 @@ -------------------------------------------------------------------------------- newTestProvider :: Store -> IO Provider-newTestProvider store = newProvider store (const $ return False) $- providerDirectory testConfiguration+newTestProvider store = do+ let dir = providerDirectory testConfiguration+ (p, _) <- newProvider store (const $ return False) dir+ pure p --------------------------------------------------------------------------------@@ -77,14 +80,23 @@ result <- testCompiler store provider underlying compiler case result of CompilerDone x _ -> return x- CompilerError e -> error $+ CompilerError e -> fail $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++- " threw: " ++ intercalate "; " e- CompilerRequire i _ -> error $+ " threw: " ++ intercalate "; " (compilerErrorMessages e)+ CompilerRequire i _ -> fail $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++ " requires: " ++ show i-+ CompilerSnapshot _ _ -> fail+ "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot" +testCompilerError :: Store -> Provider -> Identifier -> Compiler a -> String -> IO ()+testCompilerError store provider underlying compiler expectedMessage = do+ result <- testCompiler store provider underlying compiler+ case result of+ CompilerError e ->+ any (expectedMessage `isInfixOf`) (compilerErrorMessages e) @?+ "Expecting '" ++ expectedMessage ++ "' error"+ _ -> assertFailure "Expecting CompilerError" -------------------------------------------------------------------------------- testConfiguration :: Configuration@@ -102,3 +114,13 @@ removeDirectory $ destinationDirectory testConfiguration removeDirectory $ storeDirectory testConfiguration removeDirectory $ tmpDirectory testConfiguration+++--------------------------------------------------------------------------------+-- | like 'Hakyll.Web.Pandoc.renderPandoc'+-- | but allowing to test without the @usePandoc@ flag+renderParagraphs :: Item String -> Compiler (Item String)+renderParagraphs = withItemBody (return+ . intercalate "\n" -- no trailing line+ . map (("<p>"++) . (++"</p>"))+ . lines)
+ tests/data/biblio/chicago.csl view
@@ -0,0 +1,648 @@+<?xml version="1.0" encoding="utf-8"?>+<style xmlns="http://purl.org/net/xbiblio/csl" class="in-text" version="1.0" demote-non-dropping-particle="display-and-sort" page-range-format="chicago">+ <info>+ <title>Chicago Manual of Style 17th edition (author-date)</title>+ <id>http://www.zotero.org/styles/chicago-author-date</id>+ <link href="http://www.zotero.org/styles/chicago-author-date" rel="self"/>+ <link href="http://www.chicagomanualofstyle.org/tools_citationguide.html" rel="documentation"/>+ <author>+ <name>Julian Onions</name>+ <email>julian.onions@gmail.com</email>+ </author>+ <contributor>+ <name>Sebastian Karcher</name>+ </contributor>+ <contributor>+ <name>Richard Karnesky</name>+ <email>karnesky+zotero@gmail.com</email>+ <uri>http://arc.nucapt.northwestern.edu/Richard_Karnesky</uri>+ </contributor>+ <contributor>+ <name>Andrew Dunning</name>+ <email>andrew.dunning@utoronto.ca</email>+ <uri>https://orcid.org/0000-0003-0464-5036</uri>+ </contributor>+ <contributor>+ <name>Matthew Roth</name>+ <email>matthew.g.roth@yale.edu</email>+ <uri> https://orcid.org/0000-0001-7902-6331</uri>+ </contributor>+ <category citation-format="author-date"/>+ <category field="generic-base"/>+ <summary>The author-date variant of the Chicago style</summary>+ <updated>2018-01-24T12:00:00+00:00</updated>+ <rights license="http://creativecommons.org/licenses/by-sa/3.0/">This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License</rights>+ </info>+ <locale xml:lang="en">+ <terms>+ <term name="editor" form="verb-short">ed.</term>+ <term name="container-author" form="verb">by</term>+ <term name="translator" form="verb-short">trans.</term>+ <term name="editortranslator" form="verb">edited and translated by</term>+ <term name="translator" form="short">trans.</term>+ </terms>+ </locale>+ <macro name="secondary-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="none">+ <group delimiter=". ">+ <names variable="editor translator" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="director" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="container-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <group prefix=", " delimiter=", ">+ <names variable="container-author" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="editor translator" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="editor">+ <names variable="editor">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="translator">+ <names variable="translator">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="recipient">+ <choose>+ <if type="personal_communication">+ <choose>+ <if variable="genre">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ <else>+ <text term="letter" text-case="capitalize-first"/>+ </else>+ </choose>+ </if>+ </choose>+ <names variable="recipient" delimiter=", ">+ <label form="verb" prefix=" " text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="substitute-title">+ <choose>+ <if type="article-magazine article-newspaper review review-book" match="any">+ <text macro="container-title"/>+ </if>+ </choose>+ </macro>+ <macro name="contributors">+ <group delimiter=". ">+ <names variable="author">+ <name and="text" name-as-sort-order="first" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ <text macro="recipient"/>+ </group>+ </macro>+ <macro name="contributors-short">+ <names variable="author">+ <name form="short" and="text" delimiter=", " initialize-with=". "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ </macro>+ <macro name="interviewer">+ <names variable="interviewer" delimiter=", ">+ <label form="verb" prefix=" " text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="archive">+ <group delimiter=". ">+ <text variable="archive_location" text-case="capitalize-first"/>+ <text variable="archive"/>+ <text variable="archive-place"/>+ </group>+ </macro>+ <macro name="access">+ <group delimiter=". ">+ <choose>+ <if type="graphic report" match="any">+ <text macro="archive"/>+ </if>+ <else-if type="article-journal bill book chapter legal_case legislation motion_picture paper-conference" match="none">+ <text macro="archive"/>+ </else-if>+ </choose>+ <choose>+ <if type="webpage post-weblog" match="any">+ <date variable="issued" form="text"/>+ </if>+ </choose>+ <choose>+ <if variable="issued" match="none">+ <group delimiter=" ">+ <text term="accessed" text-case="capitalize-first"/>+ <date variable="accessed" form="text"/>+ </group>+ </if>+ </choose>+ <choose>+ <if type="legal_case" match="none">+ <choose>+ <if variable="DOI">+ <text variable="DOI" prefix="https://doi.org/"/>+ </if>+ <else>+ <text variable="URL"/>+ </else>+ </choose>+ </if>+ </choose>+ </group>+ </macro>+ <macro name="title">+ <choose>+ <if variable="title" match="none">+ <choose>+ <if type="personal_communication" match="none">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ </if>+ <else-if type="bill book graphic legislation motion_picture song" match="any">+ <text variable="title" text-case="title" font-style="italic"/>+ <group prefix=" (" suffix=")" delimiter=" ">+ <text term="version"/>+ <text variable="version"/>+ </group>+ </else-if>+ <else-if variable="reviewed-author">+ <choose>+ <if variable="reviewed-title">+ <group delimiter=". ">+ <text variable="title" text-case="title" quotes="true"/>+ <group delimiter=", ">+ <text variable="reviewed-title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </group>+ </if>+ <else>+ <group delimiter=", ">+ <text variable="title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </else>+ </choose>+ </else-if>+ <else-if type="legal_case interview patent" match="any">+ <text variable="title"/>+ </else-if>+ <else>+ <text variable="title" text-case="title" quotes="true"/>+ </else>+ </choose>+ </macro>+ <macro name="edition">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=". ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short" strip-periods="true"/>+ </group>+ </if>+ <else>+ <text variable="edition" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ </if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=", ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short"/>+ </group>+ </if>+ <else>+ <text variable="edition" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators">+ <choose>+ <if type="article-journal">+ <choose>+ <if variable="volume">+ <text variable="volume" prefix=" "/>+ <group prefix=" (" suffix=")">+ <choose>+ <if variable="issue">+ <text variable="issue"/>+ </if>+ <else>+ <date variable="issued">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </group>+ </if>+ <else-if variable="issue">+ <group delimiter=" " prefix=", ">+ <text term="issue" form="short"/>+ <text variable="issue"/>+ <date variable="issued" prefix="(" suffix=")">+ <date-part name="month"/>+ </date>+ </group>+ </else-if>+ <else>+ <date variable="issued" prefix=", ">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </if>+ <else-if type="legal_case">+ <text variable="volume" prefix=", "/>+ <text variable="container-title" prefix=" "/>+ <text variable="page" prefix=" "/>+ </else-if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <group prefix=". " delimiter=". ">+ <group>+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ <group>+ <number variable="number-of-volumes" form="numeric"/>+ <text term="volume" form="short" prefix=" " plural="true"/>+ </group>+ </group>+ </else-if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page" match="none">+ <group prefix=". ">+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ </if>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators-chapter">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page">+ <group prefix=", ">+ <text variable="volume" suffix=":"/>+ <text variable="page"/>+ </group>+ </if>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="locators-article">+ <choose>+ <if type="article-newspaper">+ <group prefix=", " delimiter=", ">+ <group delimiter=" ">+ <text variable="edition"/>+ <text term="edition"/>+ </group>+ <group>+ <text term="section" form="short" suffix=" "/>+ <text variable="section"/>+ </group>+ </group>+ </if>+ <else-if type="article-journal">+ <choose>+ <if variable="volume issue" match="any">+ <text variable="page" prefix=": "/>+ </if>+ <else>+ <text variable="page" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="point-locators">+ <choose>+ <if variable="locator">+ <choose>+ <if locator="page" match="none">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if variable="volume">+ <group>+ <text term="volume" form="short" suffix=" "/>+ <number variable="volume" form="numeric"/>+ <label variable="locator" form="short" prefix=", " suffix=" "/>+ </group>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <number variable="volume" form="numeric" suffix=":"/>+ </else-if>+ </choose>+ <text variable="locator"/>+ </if>+ </choose>+ </macro>+ <macro name="container-prefix">+ <text term="in" text-case="capitalize-first"/>+ </macro>+ <macro name="container-title">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <text macro="container-prefix" suffix=" "/>+ </if>+ </choose>+ <choose>+ <if type="webpage">+ <text variable="container-title" text-case="title"/>+ </if>+ <else-if type="legal_case" match="none">+ <group delimiter=" ">+ <text variable="container-title" text-case="title" font-style="italic"/>+ <choose>+ <if type="post-weblog">+ <text value="(blog)"/>+ </if>+ </choose>+ </group>+ </else-if>+ </choose>+ </macro>+ <macro name="publisher">+ <group delimiter=": ">+ <text variable="publisher-place"/>+ <text variable="publisher"/>+ </group>+ </macro>+ <macro name="date">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="(" suffix=")"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status" text-case="capitalize-first"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="date-in-text">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="[" suffix="]"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="day-month">+ <date variable="issued">+ <date-part name="month"/>+ <date-part name="day" prefix=" "/>+ </date>+ </macro>+ <macro name="collection-title">+ <choose>+ <if match="none" type="article-journal">+ <choose>+ <if match="none" is-numeric="collection-number">+ <group delimiter=", ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ <else>+ <group delimiter=" ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </else>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="collection-title-journal">+ <choose>+ <if type="article-journal">+ <group delimiter=" ">+ <text variable="collection-title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="event">+ <group>+ <text term="presented at" suffix=" "/>+ <text variable="event"/>+ </group>+ </macro>+ <macro name="description">+ <choose>+ <if type="interview">+ <group delimiter=". ">+ <text macro="interviewer"/>+ <text variable="medium" text-case="capitalize-first"/>+ </group>+ </if>+ <else-if type="patent">+ <group delimiter=" " prefix=". ">+ <text variable="authority"/>+ <text variable="number"/>+ </group>+ </else-if>+ <else>+ <text variable="medium" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ <choose>+ <if variable="title" match="none"/>+ <else-if type="thesis personal_communication speech" match="any"/>+ <else>+ <group delimiter=" " prefix=". ">+ <text variable="genre" text-case="capitalize-first"/>+ <choose>+ <if type="report">+ <text variable="number"/>+ </if>+ </choose>+ </group>+ </else>+ </choose>+ </macro>+ <macro name="issue">+ <choose>+ <if type="legal_case">+ <text variable="authority" prefix=". "/>+ </if>+ <else-if type="speech">+ <group prefix=". " delimiter=", ">+ <group delimiter=" ">+ <text variable="genre" text-case="capitalize-first"/>+ <text macro="event"/>+ </group>+ <text variable="event-place"/>+ <text macro="day-month"/>+ </group>+ </else-if>+ <else-if type="article-newspaper article-magazine personal_communication" match="any">+ <date variable="issued" form="text" prefix=", "/>+ </else-if>+ <else-if type="patent">+ <group delimiter=", " prefix=", ">+ <group delimiter=" ">+ <!--Needs Localization-->+ <text value="filed"/>+ <date variable="submitted" form="text"/>+ </group>+ <group delimiter=" ">+ <choose>+ <if variable="issued submitted" match="all">+ <text term="and"/>+ </if>+ </choose>+ <!--Needs Localization-->+ <text value="issued"/>+ <date variable="issued" form="text"/>+ </group>+ </group>+ </else-if>+ <else-if type="article-journal" match="any"/>+ <else>+ <group prefix=". " delimiter=", ">+ <choose>+ <if type="thesis">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ <text macro="publisher"/>+ </group>+ </else>+ </choose>+ </macro>+ <citation et-al-min="4" et-al-use-first="1" disambiguate-add-year-suffix="true" disambiguate-add-names="true" disambiguate-add-givenname="true" givenname-disambiguation-rule="primary-name" collapse="year">+ <layout prefix="(" suffix=")" delimiter="; ">+ <group delimiter=", ">+ <choose>+ <if variable="issued accessed" match="any">+ <group delimiter=" ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </if>+ <!---comma before forthcoming and n.d.-->+ <else>+ <group delimiter=", ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </else>+ </choose>+ <text macro="point-locators"/>+ </group>+ </layout>+ </citation>+ <bibliography hanging-indent="true" et-al-min="11" et-al-use-first="7" subsequent-author-substitute="———" entry-spacing="0">+ <sort>+ <key macro="contributors"/>+ <key variable="issued"/>+ <key variable="title"/>+ </sort>+ <layout suffix=".">+ <group delimiter=". ">+ <text macro="contributors"/>+ <text macro="date"/>+ <text macro="title"/>+ </group>+ <text macro="description"/>+ <text macro="secondary-contributors" prefix=". "/>+ <text macro="container-title" prefix=". "/>+ <text macro="container-contributors"/>+ <text macro="edition"/>+ <text macro="locators-chapter"/>+ <text macro="collection-title-journal" prefix=", " suffix=", "/>+ <text macro="locators"/>+ <text macro="collection-title" prefix=". "/>+ <text macro="issue"/>+ <text macro="locators-article"/>+ <text macro="access" prefix=". "/>+ </layout>+ </bibliography>+</style>
+ tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-lipovaca2012" class="csl-entry" role="doc-biblioentry">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple.markdown view
@@ -0,0 +1,7 @@+---+title: This page cites a paper and a book.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.++And also a book [@lipovaca2012].
+ tests/data/biblio/default.html view
@@ -0,0 +1,11 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>$title$</title>+ </head>+ <body>+ <h1>$title$</h1>+ $body$+ </body>+</html>
+ tests/data/biblio/page.markdown view
@@ -0,0 +1,5 @@+---+title: This page cites a paper.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.
+ tests/data/biblio/refs.bib view
@@ -0,0 +1,8 @@+@inproceedings{meijer1991functional,+ title={Functional programming with bananas, lenses, envelopes and barbed wire},+ author={Meijer, Erik and Fokkinga, Maarten and Paterson, Ross},+ booktitle={Conference on Functional Programming Languages and Computer Architecture},+ pages={124--144},+ year={1991},+ organization={Springer}+}
+ tests/data/biblio/refs.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: meijer1991functional+ author:+ - family: Meijer+ given: Erik+ - family: Fokkinga+ given: Maarten+ - family: Paterson+ given: Ross+ container-title: Conference on functional programming languages and computer architecture+ issued:+ - year: 1991+ page: 124–144+ publisher: Springer+ title: Functional programming with bananas, lenses, envelopes and barbed wire+ type: paper-conference+...
+ tests/data/biblio/refs2.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: lipovaca2012+ author:+ - family: Lipovača+ given: Miran+ call-number: QA76.73.H37 L69 2012+ event-place: San Francisco, CA+ ISBN: 978-1-59327-283-8+ issued:+ - year: 2012+ number-of-pages: '375'+ publisher: No Starch Press+ publisher-place: San Francisco, CA+ source: Library of Congress ISBN+ title: Learn you a Haskell for great good! a beginner's guide+ type: book+...
+ tests/data/embed.html view
@@ -0,0 +1,1 @@+<p>$body$</p>
tests/data/example.md.metadata view
@@ -1,3 +1,5 @@ external: External data date: 2012-10-22 14:35:24 subblog: food+intfield: 42+numfield: 3.14
+ tests/data/just-meta.html view
@@ -0,0 +1,7 @@+<pre>+external: {$external$}+date: {$date$}+subblog: {$subblog$}+intfield: {$intfield$}+numfield: {$numfield$}+</pre>
+ tests/data/just-meta.html.out view
@@ -0,0 +1,7 @@+<pre>+external: {External data}+date: {2012-10-22 14:35:24}+subblog: {food}+intfield: {42}+numfield: {3.14}+</pre>
+ tests/data/partial-helper.html view
@@ -0,0 +1,3 @@+<p>This is an included partial.</p>++$body$
+ tests/data/partial.html view
@@ -0,0 +1,3 @@+<p>This is a file that includes a partial.</p>++$partial("partial-helper.html")$
+ tests/data/partial.html.out view
@@ -0,0 +1,7 @@+<p>This is a file that includes a partial.</p>++<p>This is an included partial.</p>++This is an example.++
+ tests/data/posts/2018-09-26.md view
@@ -0,0 +1,1 @@+Something happened today.
+ tests/data/posts/2019/05/10/tomorrow.md view
@@ -0,0 +1,1 @@+This day hasn't happened yet (as of writing this).
+ tests/data/strip.html view
@@ -0,0 +1,34 @@+<div>+ I'm so rich I have $$3.++ $rev("foo")$+ $-rev(rev("foo"))$++ $if(body)-$+ I have body+ $else-$+ or no+ $-endif-$++ $if(unbound)$+ should not be printed+ $endif$++ $-if(body)-$+ should be printed+ $-endif$++ <ul>+ $for(authors)-$+ <li>$name$</li>+ $endfor-$+ </ul>++ $for(authors)-$+ $name-$+ $sep$,+ $-endfor$++ $body$+</div>+
+ tests/data/strip.html.out view
@@ -0,0 +1,18 @@+<div>+ I'm so rich I have $3.++ ooffoo++ I have body+ should be printed++ <ul>+ <li>Jan</li>+ <li>Piet</li>+ </ul>++ Jan,Piet++ <p>This is an example.</p>+</div>+
+ tests/data/template-empty.html view
+ web/site.hs view
@@ -0,0 +1,89 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad (filterM, forM_)+import Data.List (sortBy)+import Data.Ord (comparing)+import Hakyll+import System.Directory (copyFile)+import qualified Text.Pandoc as Pandoc+++--------------------------------------------------------------------------------+main :: IO ()+main = hakyllWith config $ do+ -- Copy CHANGELOG.md here.+ preprocess $ copyFile "../CHANGELOG.md" "releases.markdown"++ -- CSS+ match "css/*" $ do+ route idRoute+ compile compressCssCompiler++ -- Static directories+ forM_ ["images/*", "examples/*"] $ \f -> match f $ do+ route idRoute+ compile copyFileCompiler++ -- Pages+ match "*.markdown" $ do+ route $ setExtension "html"+ compile $ pandocCompiler+ >>= loadAndApplyTemplate "templates/default.html" defaultContext+ >>= relativizeUrls++ -- Tutorials+ match "tutorials/*" $ do+ route $ setExtension "html"+ compile $ pandocCompilerWith defaultHakyllReaderOptions withToc+ >>= loadAndApplyTemplate "templates/tutorial.html" defaultContext+ >>= loadAndApplyTemplate "templates/default.html" defaultContext+ >>= relativizeUrls++ -- Tutorial list+ create ["tutorials.html"] $ do+ route idRoute+ compile $ do+ ctx <- tutorialsCtx <$>+ sortBy (comparing itemIdentifier) <$> loadAll "tutorials/*"+ makeItem ""+ >>= loadAndApplyTemplate "templates/tutorials.html" ctx+ >>= loadAndApplyTemplate "templates/default.html" ctx+ >>= relativizeUrls++ -- Templates+ match "templates/*" $ compile templateCompiler+ where+ withToc = defaultHakyllWriterOptions+ { Pandoc.writerTableOfContents = True+ , Pandoc.writerTemplate = Just tocTemplate+ }++ -- When did it get so hard to compile a string to a Pandoc template?+ tocTemplate =+ either error id $ either (error . show) id $+ Pandoc.runPure $ Pandoc.runWithDefaultPartials $+ Pandoc.compileTemplate "" "$toc$\n$body$"+++--------------------------------------------------------------------------------+config :: Configuration+config = defaultConfiguration+ { deployCommand =+ "rsync --checksum -av _site/* anmitsu:jaspervdj.be/hakyll/"+ }+++--------------------------------------------------------------------------------+-- | Partition tutorials into tutorial series, other articles, external articles+tutorialsCtx :: [Item String] -> Context String+tutorialsCtx tuts =+ constField "title" "Tutorials" <>+ listField "main" defaultContext (ofType "main") <>+ listField "articles" defaultContext (ofType "article") <>+ listField "externals" defaultContext (ofType "external") <>+ listField "robertwpearce" defaultContext (ofType "robertwpearce") <>+ defaultContext+ where+ ofType ty = filterM (\item -> do+ mbType <- getMetadataField (itemIdentifier item) "type"+ return $ Just ty == mbType) tuts