diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,416 @@ # 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 @@ -78,7 +488,7 @@ - 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 servier (contribution by Arguggi) +- 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) diff --git a/data/example/css/default.css b/data/example/css/default.css --- a/data/example/css/default.css +++ b/data/example/css/default.css @@ -1,56 +1,141 @@ +html { + font-size: 62.5%; +} + body { - color: black; - font-size: 16px; - margin: 0px auto 0px auto; - width: 600px; + font-size: 1.6rem; + color: #000; } header { - border-bottom: 2px solid black; - margin-bottom: 30px; - padding: 12px 0px 12px 0px; + border-bottom: 0.2rem solid #000; } nav { - text-align: right; + text-align: right; } nav a { - color: black; - font-size: 18px; - font-weight: bold; - margin-left: 12px; - text-decoration: none; - text-transform: uppercase; + font-size: 1.8rem; + font-weight: bold; + color: black; + text-decoration: none; + text-transform: uppercase; } footer { - border-top: solid 2px black; - color: #555; - font-size: 12px; - margin-top: 30px; - padding: 12px 0px 12px 0px; - text-align: right; + 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; } article .header { - color: #555; - font-size: 14px; - font-style: italic; + font-size: 1.4rem; + font-style: italic; + color: #555; } .logo a { - color: black; + 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: 18px; - font-weight: bold; - text-decoration: none; + font-size: 1.8rem; + } } diff --git a/data/example/site.hs b/data/example/site.hs --- a/data/example/site.hs +++ b/data/example/site.hs @@ -49,7 +49,6 @@ posts <- recentFirst =<< loadAll "posts/*" let indexCtx = listField "posts" postCtx (return posts) `mappend` - constField "title" "Home" `mappend` defaultContext getResourceBody diff --git a/data/templates/atom.xml b/data/templates/atom.xml --- a/data/templates/atom.xml +++ b/data/templates/atom.xml @@ -1,12 +1,15 @@ $title$ + $root$$url$ $authorName$ + $if(authorEmail)$ $authorEmail$ + $endif$ $updated$ $body$ diff --git a/data/templates/feed-item.json b/data/templates/feed-item.json new file mode 100644 --- /dev/null +++ b/data/templates/feed-item.json @@ -0,0 +1,8 @@ +{ + "id": "$root$$url$", + "url": "$root$$url$", + "content_html": "$description$", + "title": "$title$", + "date_published": "$published$", + "date_modified": "$updated$" +} diff --git a/data/templates/feed.json b/data/templates/feed.json new file mode 100644 --- /dev/null +++ b/data/templates/feed.json @@ -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$ ] +} diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.9.8.0 +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,13 +56,23 @@ 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 @@ -72,31 +82,54 @@ 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: lib + Ghc-Options: -Wall + Hs-Source-Dirs: lib + Default-language: Haskell2010 Exposed-Modules: Hakyll @@ -127,10 +160,10 @@ Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls + Hakyll.Web.Meta.JSONLD + Hakyll.Web.Meta.OpenGraph + Hakyll.Web.Meta.TwitterCard Hakyll.Web.Paginate - Hakyll.Web.Pandoc - Hakyll.Web.Pandoc.Biblio - Hakyll.Web.Pandoc.FileType Hakyll.Web.Redirect Hakyll.Web.Tags Hakyll.Web.Template @@ -145,55 +178,53 @@ Data.Yaml.Extended Hakyll.Check Hakyll.Core.Compiler.Require + Hakyll.Core.Identifier.Pattern.Internal Hakyll.Core.Item.SomeItem Hakyll.Core.Provider.Internal Hakyll.Core.Provider.MetadataCache 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.10, - blaze-markup >= 0.5.1 && < 0.9, - bytestring >= 0.9 && < 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.4, - 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.20, - pandoc-citeproc >= 0.10.5 && < 0.11, - parsec >= 3.0 && < 3.2, - process >= 1.0 && < 1.6, - 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.8, - time-locale-compat >= 0.1 && < 0.2, - unordered-containers >= 0.2 && < 0.3, - vector >= 0.11 && < 0.13, - yaml >= 0.8.11 && < 0.9, - optparse-applicative >= 0.12 && < 0.15 + 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: wai >= 3.2 && < 3.3, - warp >= 3.2 && < 3.3, - wai-app-static >= 3.1 && < 3.2, - http-types >= 0.9 && < 0.10, - fsnotify >= 0.2 && < 0.3, - system-filepath >= 0.4.6 && <= 0.5 + warp >= 3.2 && < 3.5, + http-types >= 0.9 && < 0.13, + fsnotify >= 0.2 && < 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules: @@ -202,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: @@ -211,16 +241,33 @@ If flag(checkExternal) Build-depends: - http-conduit >= 2.2 && < 2.3, - 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: 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 @@ -236,83 +283,81 @@ 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: hakyll, - QuickCheck >= 2.8 && < 2.11, - tasty >= 0.11 && < 0.12, - tasty-hunit >= 0.9 && < 0.10, - tasty-quickcheck >= 0.8 && < 0.10, + 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.10, - blaze-markup >= 0.5.1 && < 0.9, - bytestring >= 0.9 && < 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.4, - 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.20, - pandoc-citeproc >= 0.10.5 && < 0.11, - parsec >= 3.0 && < 3.2, - process >= 1.0 && < 1.6, - 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.8, - time-locale-compat >= 0.1 && < 0.2, - unordered-containers >= 0.2 && < 0.3, - vector >= 0.11 && < 0.13, - yaml >= 0.8.11 && < 0.9, - optparse-applicative >= 0.12 && < 0.15 + 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: - wai >= 3.2 && < 3.3, - warp >= 3.2 && < 3.3, - wai-app-static >= 3.1 && < 3.2, - http-types >= 0.9 && < 0.10, - fsnotify >= 0.2 && < 0.3, - system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER If flag(watchServer) - Build-depends: - fsnotify >= 0.2 && < 0.3, - system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER If flag(checkExternal) - Build-depends: - http-conduit >= 2.2 && < 2.3, - http-types >= 0.7 && < 0.10 Cpp-options: -DCHECK_EXTERNAL + 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 + + Executable hakyll-init - Ghc-options: -Wall - Hs-source-dirs: src - Main-is: Init.hs + Main-is: Init.hs + Ghc-options: -Wall -threaded + Hs-source-dirs: src + Default-language: Haskell2010 + Other-modules: + Paths_hakyll + Build-depends: hakyll, - base >= 4 && < 5, - directory >= 1.0 && < 1.4, - filepath >= 1.0 && < 1.5 + 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 diff --git a/lib/Hakyll.hs b/lib/Hakyll.hs --- a/lib/Hakyll.hs +++ b/lib/Hakyll.hs @@ -20,10 +20,15 @@ , module Hakyll.Web.Feed , module Hakyll.Web.Html , module Hakyll.Web.Html.RelativizeUrls - , module Hakyll.Web.Pandoc + , 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 @@ -51,10 +56,15 @@ 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 diff --git a/lib/Hakyll/Check.hs b/lib/Hakyll/Check.hs --- a/lib/Hakyll/Check.hs +++ b/lib/Hakyll/Check.hs @@ -17,15 +17,13 @@ import Control.Monad.State (StateT, get, modify, runStateT) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Resource (runResourceT) -import Data.ByteString.Char8 (unpack) 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, takeExtension, - ()) +import System.FilePath (takeDirectory, ()) import qualified Text.HTML.TagSoup as TS @@ -86,12 +84,15 @@ -------------------------------------------------------------------------------- -instance Monoid CheckerWrite where - mempty = CheckerWrite 0 0 - mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) = +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) @@ -127,7 +128,7 @@ let htmls = [ destinationDirectory config file | file <- files - , takeExtension file == ".html" + , checkHtmlFile config file ] forM_ htmls checkFile @@ -247,7 +248,9 @@ -- Convert exception to a concise form showException e = case cast e of Just (Http.HttpExceptionRequest _ e') -> show e' - _ -> head $ words $ 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 @@ -256,7 +259,8 @@ request <- Http.parseRequest url response <- Http.http (settings request) mgr let code = Http.statusCode (Http.responseStatus response) - return $ code >= 200 && code < 300 + -- 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 diff --git a/lib/Hakyll/Commands.hs b/lib/Hakyll/Commands.hs --- a/lib/Hakyll/Commands.hs +++ b/lib/Hakyll/Commands.hs @@ -2,7 +2,8 @@ -- | Implementation of Hakyll commands: build, preview... {-# LANGUAGE CPP #-} module Hakyll.Commands - ( build + ( Check(..) + , build , check , clean , preview @@ -15,9 +16,11 @@ -------------------------------------------------------------------------------- import Control.Concurrent -import System.Exit (ExitCode, exitWith) +import System.Exit (ExitCode) + -------------------------------------------------------------------------------- +import Hakyll.Check (Check(..)) import qualified Hakyll.Check as Check import Hakyll.Core.Configuration import Hakyll.Core.Logger (Logger) @@ -27,6 +30,7 @@ import Hakyll.Core.Runtime import Hakyll.Core.Util.File + -------------------------------------------------------------------------------- #ifdef WATCH_SERVER import Hakyll.Preview.Poll (watchUpdates) @@ -44,8 +48,8 @@ -------------------------------------------------------------------------------- -- | Build the site -build :: Configuration -> Logger -> Rules a -> IO ExitCode -build conf logger rules = fst <$> run conf logger rules +build :: RunMode -> Configuration -> Logger -> Rules a -> IO ExitCode +build mode conf logger rules = fst <$> run mode conf logger rules -------------------------------------------------------------------------------- @@ -94,14 +98,14 @@ #else -- Force windows users to compile with -threaded flag, as otherwise -- thread is blocked indefinitely. - catchIOError (void $ forkOS $ watchUpdates conf update) $ do + 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 + (_, ruleSet) <- run RunModeNormal conf logger rules return $ rulesPattern ruleSet loop = threadDelay 100000 >> loop server' = if runServer then server conf logger host port else loop @@ -113,15 +117,15 @@ -- | Rebuild the site rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode rebuild conf logger rules = - clean conf logger >> build 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 destination = destinationDirectory conf - staticServer logger destination host port + let settings = previewSettings conf $ destinationDirectory conf + staticServer logger settings host port #else server _ _ _ _ = previewServerDisabled #endif @@ -137,24 +141,30 @@ -- | 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." - ] +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 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." - ] +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 diff --git a/lib/Hakyll/Core/Compiler.hs b/lib/Hakyll/Core/Compiler.hs --- a/lib/Hakyll/Core/Compiler.hs +++ b/lib/Hakyll/Core/Compiler.hs @@ -22,15 +22,19 @@ , Internal.loadAllSnapshots , cached + , recompilingUnsafeCompiler , unsafeCompiler , debugCompiler + , noResult + , withErrorMessage ) where -------------------------------------------------------------------------------- -import Control.Monad (when, unless) +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) @@ -62,6 +66,7 @@ -------------------------------------------------------------------------------- +-- | Create an item from the underlying identifier and a given value. makeItem :: a -> Compiler (Item a) makeItem x = do identifier <- getUnderlying @@ -77,7 +82,7 @@ -- 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] + when um $ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] return mfp @@ -141,6 +146,10 @@ -------------------------------------------------------------------------------- +-- | 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 @@ -154,17 +163,17 @@ 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 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 + 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! " ++ @@ -177,12 +186,46 @@ -------------------------------------------------------------------------------- +-- | 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] } + -------------------------------------------------------------------------------- --- | Compiler for debugging purposes +-- | 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 diff --git a/lib/Hakyll/Core/Compiler/Internal.hs b/lib/Hakyll/Core/Compiler/Internal.hs --- a/lib/Hakyll/Core/Compiler/Internal.hs +++ b/lib/Hakyll/Core/Compiler/Internal.hs @@ -1,5 +1,7 @@ -------------------------------------------------------------------------------- -- | Internally used compiler module +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -9,19 +11,26 @@ Snapshot , CompilerRead (..) , CompilerWrite (..) + , CompilerErrors (..) , CompilerResult (..) , Compiler (..) , runCompiler -- * Core operations + , compilerResult , compilerTell , compilerAsk + , compilerUnsafeIO + + -- * Error operations , compilerThrow + , compilerNoResult , compilerCatch - , compilerResult - , compilerUnsafeIO + , compilerTry + , compilerErrorMessages -- * Utilities + , compilerDebugEntries , compilerTellDependencies , compilerTellCacheHits ) where @@ -30,8 +39,11 @@ -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..)) import Control.Exception (SomeException, handle) -import Control.Monad (forM_) -import Control.Monad.Except (MonadError (..)) +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 @@ -41,7 +53,6 @@ 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 @@ -71,7 +82,7 @@ , -- | Compiler store compilerStore :: Store , -- | Logger - compilerLogger :: Logger + compilerLogger :: Logger.Logger } @@ -83,21 +94,42 @@ -------------------------------------------------------------------------------- -instance Monoid CompilerWrite where - mempty = CompilerWrite [] 0 - mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) = +instance Semigroup CompilerWrite where + (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) = CompilerWrite (d1 ++ d2) (h1 + h2) +instance Monoid CompilerWrite where + mempty = CompilerWrite [] 0 + mappend = (<>) + -------------------------------------------------------------------------------- -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 +-- | 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 @@ -112,14 +144,14 @@ 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') + CompilerError e -> CompilerError e {-# INLINE fmap #-} -------------------------------------------------------------------------------- instance Monad Compiler where - return x = Compiler $ \_ -> return $ CompilerDone x mempty + return = pure {-# INLINE return #-} Compiler c >>= f = Compiler $ \r -> do @@ -132,23 +164,28 @@ 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' + CompilerError e -> CompilerError e CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f) - CompilerError e -> return $ CompilerError e CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f) + CompilerError e -> return $ CompilerError e {-# INLINE (>>=) #-} - fail = compilerThrow . return +#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 = return x + pure x = compilerResult $ CompilerDone x mempty {-# INLINE pure #-} f <*> x = f >>= \f' -> fmap f' x @@ -156,87 +193,150 @@ -------------------------------------------------------------------------------- +-- | Access provided metadata from anywhere instance MonadMetadata Compiler where getMetadata = compilerGetMetadata - getMatches = compilerGetMatches + 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 = compilerCatch + 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 [show e] + 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 = 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 + 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 deps = Compiler $ \_ -> return $ CompilerDone () deps +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 es = Compiler $ \_ -> return $ CompilerError es -{-# INLINE compilerThrow #-} +compilerThrow = compilerResult . CompilerError . + maybe (CompilationNoResult []) CompilationFailure . + NonEmpty.nonEmpty +-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult' +compilerNoResult :: [String] -> Compiler a +compilerNoResult = compilerResult . CompilerError . CompilationNoResult + -------------------------------------------------------------------------------- -compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a +-- | 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)) - CompilerError e -> unCompiler (f e) r CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f)) + CompilerError e -> unCompiler (f e) r {-# INLINE compilerCatch #-} -------------------------------------------------------------------------------- --- | Put the result back in a compiler -compilerResult :: CompilerResult a -> Compiler a -compilerResult x = Compiler $ \_ -> return x -{-# INLINE compilerResult #-} - +compilerDebugLog :: [String] -> Compiler () +compilerDebugLog ms = do + logger <- compilerLogger <$> compilerAsk + compilerUnsafeIO $ forM_ ms $ Logger.debug logger -------------------------------------------------------------------------------- -compilerUnsafeIO :: IO a -> Compiler a -compilerUnsafeIO io = Compiler $ \_ -> do - x <- io - return $ CompilerDone x mempty -{-# INLINE compilerUnsafeIO #-} +-- | 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 - logger <- compilerLogger <$> compilerAsk - forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $ - "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d + compilerDebugLog $ map (\d -> + "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds compilerTell mempty {compilerDependencies = ds} {-# INLINE compilerTellDependencies #-} @@ -251,15 +351,14 @@ compilerGetMetadata :: Identifier -> Compiler Metadata compilerGetMetadata identifier = do provider <- compilerProvider <$> compilerAsk - compilerTellDependencies [IdentifierDependency identifier] + compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier -------------------------------------------------------------------------------- -compilerGetMatches :: Pattern -> Compiler [Identifier] -compilerGetMatches pattern = do +compilerGetMatches :: DependencyKind -> Pattern -> Compiler [Identifier] +compilerGetMatches kind pattern = do universe <- compilerUniverse <$> compilerAsk - let matching = filterMatches pattern $ S.toList universe - set' = S.fromList matching - compilerTellDependencies [PatternDependency pattern set'] - return matching + let matching = S.filter (matches pattern) universe + compilerTellDependencies [Dependency kind $ PatternDependency pattern matching] + pure $ S.toList matching diff --git a/lib/Hakyll/Core/Compiler/Require.hs b/lib/Hakyll/Core/Compiler/Require.hs --- a/lib/Hakyll/Core/Compiler/Require.hs +++ b/lib/Hakyll/Core/Compiler/Require.hs @@ -15,6 +15,8 @@ -------------------------------------------------------------------------------- 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 @@ -55,31 +57,8 @@ -- | 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 +loadSnapshot id' snapshot = + fmap runIdentity $ loadSnapshotCollection (Identity (id', snapshot)) -------------------------------------------------------------------------------- @@ -91,6 +70,7 @@ -------------------------------------------------------------------------------- +-- | 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 @@ -103,11 +83,47 @@ -------------------------------------------------------------------------------- +-- | 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 - matching <- getMatches pattern - mapM (\i -> loadSnapshot i snapshot) matching + 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 -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Core/Configuration.hs b/lib/Hakyll/Core/Configuration.hs --- a/lib/Hakyll/Core/Configuration.hs +++ b/lib/Hakyll/Core/Configuration.hs @@ -3,6 +3,7 @@ module Hakyll.Core.Configuration ( Configuration (..) , shouldIgnoreFile + , shouldWatchIgnore , defaultConfiguration ) where @@ -10,9 +11,11 @@ -------------------------------------------------------------------------------- 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, normalise, takeFileName) +import System.FilePath (isAbsolute, makeRelative, normalise, + takeExtension, takeFileName) import System.IO.Error (catchIOError) import System.Process (system) @@ -45,6 +48,18 @@ -- 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: @@ -78,6 +93,9 @@ -- 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 } -------------------------------------------------------------------------------- @@ -93,11 +111,14 @@ , 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 @@ -114,7 +135,9 @@ -- | Check if a file should be ignored shouldIgnoreFile :: Configuration -> FilePath -> IO Bool shouldIgnoreFile conf path = orM - [ inDir (destinationDirectory conf) + [ 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') @@ -132,3 +155,11 @@ 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) diff --git a/lib/Hakyll/Core/Dependencies.hs b/lib/Hakyll/Core/Dependencies.hs --- a/lib/Hakyll/Core/Dependencies.hs +++ b/lib/Hakyll/Core/Dependencies.hs @@ -1,9 +1,14 @@ -------------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} module Hakyll.Core.Dependencies ( Dependency (..) + , DependencySelector (..) + , DependencyKind (..) , DependencyFacts , outOfDate + , contentDependency + , metadataDependency ) where @@ -15,6 +20,7 @@ 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 @@ -30,34 +36,69 @@ -------------------------------------------------------------------------------- -data Dependency +data DependencySelector = PatternDependency Pattern (Set Identifier) | IdentifierDependency Identifier deriving (Show, Typeable) - -------------------------------------------------------------------------------- -instance Binary Dependency where +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 - _ -> error "Data.Binary.get: Invalid Dependency" + _ -> 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 -- ^ Initially out-of-date resources + -> Set Identifier -- ^ Changed content + -> Set Identifier -- ^ Changed metadata -> DependencyFacts -- ^ Old dependency facts -> (Set Identifier, DependencyFacts, [String]) -outOfDate universe ood oldFacts = - let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood) +outOfDate universe ood oodMeta oldFacts = + let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood oodMeta) in (dependencyOod state, dependencyFacts state, logs) where rws = do @@ -68,8 +109,9 @@ -------------------------------------------------------------------------------- data DependencyState = DependencyState - { dependencyFacts :: DependencyFacts - , dependencyOod :: Set Identifier + { dependencyFacts :: DependencyFacts + , dependencyOod :: Set Identifier + , dependencyOodMeta :: Set Identifier } deriving (Show) @@ -84,15 +126,48 @@ -------------------------------------------------------------------------------- -dependenciesFor :: Identifier -> DependencyM [Identifier] +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 $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts + return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts where - dependenciesFor' (IdentifierDependency i) = [i] - dependenciesFor' (PatternDependency _ is) = S.toList is + 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 @@ -112,18 +187,21 @@ 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 + 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 : ds + then return $ PatternDependency p ls else do tell [show id' ++ " is out-of-date because a pattern changed"] markOod id' - return $ PatternDependency p ls' : ds + 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 @@ -134,13 +212,26 @@ (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' - 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) + 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) diff --git a/lib/Hakyll/Core/Identifier.hs b/lib/Hakyll/Core/Identifier.hs --- a/lib/Hakyll/Core/Identifier.hs +++ b/lib/Hakyll/Core/Identifier.hs @@ -1,12 +1,16 @@ -------------------------------------------------------------------------------- --- | An identifier is a type used to uniquely identify an item. An identifier is --- conceptually similar to a file path. Examples of identifiers are: +-- | 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 @@ -20,8 +24,7 @@ -------------------------------------------------------------------------------- import Control.DeepSeq (NFData (..)) -import Data.List (intercalate) -import System.FilePath (dropTrailingPathSeparator, splitPath) +import System.FilePath (normalise) -------------------------------------------------------------------------------- @@ -31,6 +34,70 @@ -------------------------------------------------------------------------------- +{- | 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 @@ -61,20 +128,42 @@ -------------------------------------------------------------------------------- --- | Parse an identifier from a string -fromFilePath :: String -> Identifier -fromFilePath = Identifier Nothing . - intercalate "/" . filter (not . null) . split' - where - split' = map dropTrailingPathSeparator . splitPath +{- | 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 to a relative 'FilePath' +-- | Convert an identifier back to a relative 'FilePath'. toFilePath :: Identifier -> FilePath -toFilePath = identifierPath +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} diff --git a/lib/Hakyll/Core/Identifier/Pattern.hs b/lib/Hakyll/Core/Identifier/Pattern.hs --- a/lib/Hakyll/Core/Identifier/Pattern.hs +++ b/lib/Hakyll/Core/Identifier/Pattern.hs @@ -27,7 +27,8 @@ -- * @\"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. +-- by the capture elements in a glob or regex pattern. +{-# OPTIONS_GHC -fno-warn-orphans #-} module Hakyll.Core.Identifier.Pattern ( -- * The pattern type Pattern @@ -57,77 +58,24 @@ -------------------------------------------------------------------------------- -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 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 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 +import Hakyll.Core.Identifier.Pattern.Internal +import Hakyll.Core.Util.String (removeWinPathSeparator) -------------------------------------------------------------------------------- @@ -136,22 +84,16 @@ -------------------------------------------------------------------------------- -instance Monoid Pattern where - mempty = Everything - mappend = (.&&.) - - --------------------------------------------------------------------------------- -- | Parse a pattern from a string fromGlob :: String -> Pattern -fromGlob = Glob . parse' +fromGlob = Glob . parse' . normalise where - parse' str = - let (chunk, rest) = break (`elem` "\\*") str + parse' str = + let (chunk, rest) = break (== '*') str in case rest of - ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs ('*' : xs) -> Literal chunk : Capture : parse' xs + "" -> Literal chunk : [] xs -> Literal chunk : Literal xs : [] @@ -242,7 +184,7 @@ 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 (Regex r) i = (removeWinPathSeparator $ toFilePath i) =~ r matches (Version v) i = identifierVersion i == v @@ -260,9 +202,11 @@ -------------------------------------------------------------------------------- --- | Match a glob against a pattern, generating a list of captures +-- | 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 @@ -276,8 +220,8 @@ | l `isPrefixOf` str = capture' ms $ drop (length l) str | otherwise = Nothing capture' (Capture : ms) str = - -- Match until the next / - let (chunk, rest) = break (== '/') 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 diff --git a/lib/Hakyll/Core/Identifier/Pattern/Internal.hs b/lib/Hakyll/Core/Identifier/Pattern/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Core/Identifier/Pattern/Internal.hs @@ -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 = (<>) diff --git a/lib/Hakyll/Core/Item.hs b/lib/Hakyll/Core/Item.hs --- a/lib/Hakyll/Core/Item.hs +++ b/lib/Hakyll/Core/Item.hs @@ -2,6 +2,7 @@ -- | 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 @@ -11,7 +12,6 @@ -------------------------------------------------------------------------------- import Data.Binary (Binary (..)) -import Data.Foldable (Foldable (..)) import Data.Typeable (Typeable) import Prelude hiding (foldr) @@ -25,23 +25,7 @@ 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 - + } deriving (Show, Typeable, Functor, Foldable, Traversable) -------------------------------------------------------------------------------- instance Binary a => Binary (Item a) where diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs --- a/lib/Hakyll/Core/Logger.hs +++ b/lib/Hakyll/Core/Logger.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs +{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Logger ( Verbosity (..) , Logger @@ -9,15 +10,20 @@ , header , message , debug + + -- * Testing utilities + , newInMem ) 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.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) @@ -30,12 +36,10 @@ -------------------------------------------------------------------------------- --- | 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 + { -- | Flush the logger (blocks until flushed) + flush :: forall m. MonadIO m => m () + , string :: forall m. MonadIO m => Verbosity -> String -> m () } @@ -43,55 +47,61 @@ -- | 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 + chan <- newChan + sync <- newEmptyMVar + _ <- forkIO $ forever $ do + msg <- readChan chan case msg of -- Stop: sync - Nothing -> putMVar (loggerSync logger) () + Nothing -> putMVar sync () -- Print and continue - Just m -> loggerSink logger m + 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) + } -------------------------------------------------------------------------------- --- | Flush the logger (blocks until flushed) -flush :: Logger -> IO () -flush logger = do - writeChan (loggerChan logger) Nothing - () <- takeMVar $ loggerSync logger - return () +error :: MonadIO m => Logger -> String -> m () +error l m = string l Error $ " [ERROR] " ++ indent m -------------------------------------------------------------------------------- -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 () +header :: MonadIO m => Logger -> String -> m () +header l = string l Message -------------------------------------------------------------------------------- -error :: MonadIO m => Logger -> String -> m () -error l m = string l Error $ " [ERROR] " ++ m +message :: MonadIO m => Logger -> String -> m () +message l m = string l Message $ " " ++ indent m -------------------------------------------------------------------------------- -header :: MonadIO m => Logger -> String -> m () -header l = string l Message +debug :: MonadIO m => Logger -> String -> m () +debug l m = string l Debug $ " [DEBUG] " ++ indent m -------------------------------------------------------------------------------- -message :: MonadIO m => Logger -> String -> m () -message l m = string l Message $ " " ++ m +indent :: String -> String +indent = intercalate "\n " . lines -------------------------------------------------------------------------------- -debug :: MonadIO m => Logger -> String -> m () -debug l m = string l Debug $ " [DEBUG] " ++ m +-- | 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 + ) diff --git a/lib/Hakyll/Core/Metadata.hs b/lib/Hakyll/Core/Metadata.hs --- a/lib/Hakyll/Core/Metadata.hs +++ b/lib/Hakyll/Core/Metadata.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module Hakyll.Core.Metadata ( Metadata , lookupString @@ -14,11 +15,18 @@ -------------------------------------------------------------------------------- -import Control.Arrow (second) import Control.Monad (forM) +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif import Data.Binary (Binary (..), getWord8, putWord8, Get) -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 +#endif import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Vector as V @@ -34,13 +42,13 @@ -------------------------------------------------------------------------------- lookupString :: String -> Metadata -> Maybe String -lookupString key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString +lookupString key meta = KeyMap.lookup (keyFromString key) meta >>= Yaml.toString -------------------------------------------------------------------------------- lookupStringList :: String -> Metadata -> Maybe [String] lookupStringList key meta = - HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString + KeyMap.lookup (keyFromString key) meta >>= Yaml.toList >>= mapM Yaml.toString -------------------------------------------------------------------------------- @@ -66,7 +74,7 @@ -------------------------------------------------------------------------------- -- | Version of 'getMetadataField' which throws an error if the field does not -- exist. -getMetadataField' :: MonadMetadata m => Identifier -> String -> m String +getMetadataField' :: (MonadFail m, MonadMetadata m) => Identifier -> String -> m String getMetadataField' identifier key = do field <- getMetadataField identifier key case field of @@ -76,10 +84,10 @@ -------------------------------------------------------------------------------- -makePatternDependency :: MonadMetadata m => Pattern -> m Dependency -makePatternDependency pattern = do +makePatternDependency :: MonadMetadata m => DependencyKind -> Pattern -> m Dependency +makePatternDependency kind pattern = do matches' <- getMatches pattern - return $ PatternDependency pattern (S.fromList matches') + return $ Dependency kind (PatternDependency pattern (S.fromList matches')) -------------------------------------------------------------------------------- @@ -105,7 +113,7 @@ Yaml.Object obj -> do putWord8 0 let list :: [(T.Text, BinaryYaml)] - list = map (second BinaryYaml) $ HMS.toList obj + list = map (\(k, v) -> (keyToText k, BinaryYaml v)) $ KeyMap.toList obj put list Yaml.Array arr -> do @@ -124,7 +132,7 @@ 0 -> do list <- get :: Get [(T.Text, BinaryYaml)] return $ BinaryYaml $ Yaml.Object $ - HMS.fromList $ map (second unBinaryYaml) list + KeyMap.fromList $ map (\(k, v) -> (keyFromText k, unBinaryYaml v)) list 1 -> do list <- get :: Get [BinaryYaml] @@ -136,3 +144,25 @@ 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 diff --git a/lib/Hakyll/Core/Provider.hs b/lib/Hakyll/Core/Provider.hs --- a/lib/Hakyll/Core/Provider.hs +++ b/lib/Hakyll/Core/Provider.hs @@ -22,22 +22,38 @@ , 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 -- ^ Resulting 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 - -- Delete metadata cache where necessary - p <- Internal.newProvider store ignore directory - mapM_ (Internal.resourceInvalidateMetadataCache p) $ - filter (Internal.resourceModified p) $ Internal.resourceList p - return p + 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) diff --git a/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs --- a/lib/Hakyll/Core/Provider/Metadata.hs +++ b/lib/Hakyll/Core/Provider/Metadata.hs @@ -19,7 +19,6 @@ 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 @@ -27,6 +26,7 @@ import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal import System.IO as IO +import System.IO.Error (modifyIOError, ioeSetLocation) -------------------------------------------------------------------------------- @@ -51,7 +51,7 @@ -------------------------------------------------------------------------------- loadMetadataHeader :: FilePath -> IO (Metadata, String) loadMetadataHeader fp = do - fileContent <- readFile fp + fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp case parsePage fileContent of Right x -> return x Left err -> throwIO $ MetadataException fp err @@ -60,7 +60,7 @@ -------------------------------------------------------------------------------- loadMetadataFile :: FilePath -> IO Metadata loadMetadataFile fp = do - fileContent <- B.readFile fp + fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp let errOrMeta = Yaml.decodeEither' fileContent either (fail . show) return errOrMeta @@ -143,9 +143,9 @@ where hint = case err of Yaml.InvalidYaml (Just (Yaml.YamlParseException {..})) - | yamlProblem == problem -> "\n" ++ + | 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." _ -> "" - - problem = "mapping values are not allowed in this context" diff --git a/lib/Hakyll/Core/Provider/MetadataCache.hs b/lib/Hakyll/Core/Provider/MetadataCache.hs --- a/lib/Hakyll/Core/Provider/MetadataCache.hs +++ b/lib/Hakyll/Core/Provider/MetadataCache.hs @@ -2,12 +2,14 @@ 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 @@ -22,9 +24,7 @@ | 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 + fromMaybe mempty <$> resourceLookupMetadataCache p r -------------------------------------------------------------------------------- @@ -34,6 +34,18 @@ 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" -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Core/Routes.hs b/lib/Hakyll/Core/Routes.hs --- a/lib/Hakyll/Core/Routes.hs +++ b/lib/Hakyll/Core/Routes.hs @@ -1,34 +1,49 @@ -------------------------------------------------------------------------------- --- | 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. +{- | '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: '/posts/hakyll.md' +> match "posts/*" $ do +> -- compilation result is written to '/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 '/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 - ( UsedMetadata - , Routes + ( Routes + , UsedMetadata , runRoutes , idRoute , setExtension @@ -42,7 +57,7 @@ -------------------------------------------------------------------------------- -import System.FilePath (replaceExtension) +import System.FilePath (replaceExtension, normalise) -------------------------------------------------------------------------------- @@ -74,15 +89,18 @@ -------------------------------------------------------------------------------- -instance Monoid Routes where - mempty = Routes $ \_ _ -> return (Nothing, False) - mappend (Routes f) (Routes g) = Routes $ \p id' -> do +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 @@ -92,30 +110,60 @@ -------------------------------------------------------------------------------- --- | A route that uses the identifier as filepath. For example, the target with --- ID @foo\/bar@ will be written to the file @foo\/bar@. +{- | 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: '/posts/hakyll.md' +> +> -- 'hakyll.md' source file implicitly gets filepath as identifier: +> -- 'posts/hakyll.md' +> match "posts/*" $ do +> +> -- compilation result is written to '/posts/hakyll.md' +> route idRoute +> +> compile getResourceBody +-} 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" +{- | 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: '/posts/hakyll.md' +> +> -- 'hakyll.md' source file implicitly gets filepath as identifier: +> -- 'posts/hakyll.md' +> match "posts/*" $ do +> +> -- compilation result is written to '/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 '/about.html' +> route (setExtension "html") +> +> compile $ makeItem ("Hello world" :: String) +-} setExtension :: String -> Routes setExtension extension = customRoute $ (`replaceExtension` extension) . toFilePath @@ -130,58 +178,172 @@ -------------------------------------------------------------------------------- --- | Create a custom route. This should almost always be used with --- 'matchRoute' -customRoute :: (Identifier -> FilePath) -> Routes +{- | 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: '/posts/hakyll.md' +> +> -- 'hakyll.md' source file implicitly gets filepath as identifier: +> -- 'posts/hakyll.md' +> match "posts/*" $ do +> +> -- compilation result is written to '/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) -------------------------------------------------------------------------------- --- | A route that always gives the same result. Obviously, you should only use --- this for a single compilation rule. +{- | 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 '/index.html' +> route $ constRoute "index.html" +> +> compile $ makeItem ("

Hello World

" :: String) +-} 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 +{- | 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: '/posts/hakyll.md' +> +> -- 'hakyll.md' source file implicitly gets filepath as identifier: +> -- 'posts/hakyll.md' +> match "posts/*" $ do +> +> -- compilation result is written to '/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 '/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 $ - replaceAll pattern replacement . toFilePath + 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 -------------------------------------------------------------------------------- --- | Get access to the metadata in order to determine the route -metadataRoute :: (Metadata -> Routes) -> Routes +{- | 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 '/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 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. +{- | 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: '/posts/hakyll.md' +> +> -- 'hakyll.md' source file implicitly gets filepath as identifier: +> -- 'posts/hakyll.md' +> match "posts/*" $ do +> +> -- compilation result is written to '/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 diff --git a/lib/Hakyll/Core/Rules.hs b/lib/Hakyll/Core/Rules.hs --- a/lib/Hakyll/Core/Rules.hs +++ b/lib/Hakyll/Core/Rules.hs @@ -1,19 +1,43 @@ -------------------------------------------------------------------------------- --- | 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: --- +-- | 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 --- > match "posts/*" $ do --- > route (setExtension "html") --- > compile someCompiler +-- > +-- > -- Rule 1 +-- > -- Source files: all Markdown files like 'hakyll.md' in the 'posts' directory +-- > match "posts/**.md" $ do +-- > -- Routing: Only replace extension, so '/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 +-- > 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 @@ -130,18 +154,122 @@ setMatches ids env = env {rulesMatches = ids} -------------------------------------------------------------------------------- -match :: Pattern -> Rules () -> Rules () +{- | 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. '/posts/hakyll.md' +> -- but NOT '/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. '/posts/hakyll.md' +> -- and '/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 -------------------------------------------------------------------------------- -matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules () +{- | 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 -------------------------------------------------------------------------------- -create :: [Identifier] -> Rules () -> Rules () +{- | 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 '/index.html' +> route idRoute +> +> -- create content without a source file from disk +> compile $ makeItem ("

Hello World

" :: 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 @@ -151,7 +279,54 @@ -------------------------------------------------------------------------------- -version :: String -> Rules () -> Rules () +{- | 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 @@ -160,19 +335,116 @@ -------------------------------------------------------------------------------- --- | 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 () +{- | 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: + +>

$title$

+> $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 a route. --- --- This adds a route for all items matching the current pattern. -route :: Routes -> Rules () +{- | 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'} diff --git a/lib/Hakyll/Core/Rules/Internal.hs b/lib/Hakyll/Core/Rules/Internal.hs --- a/lib/Hakyll/Core/Rules/Internal.hs +++ b/lib/Hakyll/Core/Rules/Internal.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal @@ -12,6 +13,9 @@ -------------------------------------------------------------------------------- +#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) @@ -52,12 +56,15 @@ -------------------------------------------------------------------------------- -instance Monoid RuleSet where - mempty = RuleSet mempty mempty mempty mempty - mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) = +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 @@ -74,7 +81,7 @@ -- | The monad used to compose rules newtype Rules a = Rules { unRules :: RWST RulesRead RuleSet RulesState IO a - } deriving (Monad, Functor, Applicative) + } deriving (Monad, MonadFail, Functor, Applicative) -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs --- a/lib/Hakyll/Core/Runtime.hs +++ b/lib/Hakyll/Core/Runtime.hs @@ -1,21 +1,35 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} module Hakyll.Core.Runtime ( run + , RunMode(..) ) 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.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 M +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 S +import qualified Data.Set as Set import System.Exit (ExitCode (..)) import System.FilePath (()) @@ -39,15 +53,25 @@ import Hakyll.Core.Writable +factsKey :: [String] +factsKey = ["Hakyll.Core.Runtime.run", "facts"] + + -------------------------------------------------------------------------------- -run :: Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet) -run config logger rules = do +-- | 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 <- newProvider store (shouldIgnoreFile config) $ + (provider, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $ providerDirectory config Logger.message logger "Running rules..." ruleSet <- runRules rules provider @@ -58,40 +82,34 @@ _ -> 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 = M.fromList compilers - } - state = RuntimeState - { runtimeDone = S.empty - , runtimeSnapshots = S.empty - , runtimeTodo = M.empty - , runtimeFacts = oldFacts + , runtimeUniverse = Map.fromList compilers + , runtimeScheduler = scheduler } -- 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 + 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) - where - factsKey = ["Hakyll.Core.Runtime.run", "facts"] + 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) -------------------------------------------------------------------------------- @@ -99,178 +117,423 @@ { runtimeConfiguration :: Configuration , runtimeLogger :: Logger , runtimeProvider :: Provider + , runtimeModifiedMeta :: Set Identifier , runtimeStore :: Store , runtimeRoutes :: Routes , runtimeUniverse :: Map Identifier (Compiler SomeItem) + , runtimeScheduler :: IORef Scheduler } -------------------------------------------------------------------------------- -data RuntimeState = RuntimeState - { runtimeDone :: Set Identifier - , runtimeSnapshots :: Set (Identifier, Snapshot) - , runtimeTodo :: Map Identifier (Compiler SomeItem) - , runtimeFacts :: DependencyFacts +-- | 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)] } -------------------------------------------------------------------------------- -type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a +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 = [] -------------------------------------------------------------------------------- -build :: Runtime () -build = do +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 - Logger.header logger "Compiling" - pickAndChase - Logger.header logger "Success" + 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 :: Runtime () +scheduleOutOfDate :: ReaderT RuntimeRead IO () 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 + 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 - -- 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 :: ReaderT RuntimeRead IO () pickAndChase = do - todo <- runtimeTodo <$> get - case M.minViewWithKey todo of - Nothing -> return () - Just ((id', _), _) -> do - chase [] id' - pickAndChase + 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 -------------------------------------------------------------------------------- -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' +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 compiler = todo M.! id' - read' = CompilerRead - { compilerConfig = config - , compilerUnderlying = id' - , compilerProvider = provider - , compilerUniverse = M.keysSet universe - , compilerRoutes = routes - , compilerStore = store - , compilerLogger = logger - } + let spawnN :: Int -> IO () + spawnN n = replicateM_ n $ forkIO $ + IORef.atomicModifyIORef' scheduler schedulerPop >>= go - 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 + 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' - -- 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) - } + spawnN numThreads + MVar.readMVar signal - -- 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)" +-------------------------------------------------------------------------------- +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 - -- 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 + 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 - -- Save! (For load) - liftIO $ save store item + CompilerSnapshot snapshot c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerSnapshot id' snapshot c - -- Update state - modify $ \s -> s - { runtimeDone = S.insert id' (runtimeDone s) - , runtimeTodo = M.delete id' (runtimeTodo s) - , runtimeFacts = M.insert id' facts (runtimeFacts s) - } + 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' - -- 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 + -- 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)" - -- 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 + -- 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 - modify $ \s -> s - { runtimeTodo = M.insert id' - (if depDone then c else compilerResult result) - (runtimeTodo s) - } + 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 - -- 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 + CompilerRequire reqs c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerBlock id' reqs c diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs --- a/lib/Hakyll/Core/Store.hs +++ b/lib/Hakyll/Core/Store.hs @@ -16,22 +16,22 @@ -------------------------------------------------------------------------------- -import Control.Exception (IOException, handle) -import qualified Crypto.Hash.MD5 as MD5 +import Control.Monad (when) 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 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 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.Directory (createDirectoryIfMissing, doesFileExist, + removeFile) import System.FilePath (()) import System.IO (IOMode (..), hClose, openFile) -import Text.Printf (printf) +import System.IO.Error (catchIOError, ioeSetFileName, + ioeSetLocation, modifyIOError) -------------------------------------------------------------------------------- @@ -42,9 +42,11 @@ -------------------------------------------------------------------------------- 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) + storeDirectory :: FilePath + , -- | See 'set' + storeWriteAhead :: IORef.IORef (Map.Map String Box) + -- | Optionally, items are also kept in-memory + , storeMap :: Maybe (Lru.AtomicLRU FilePath Box) } @@ -76,28 +78,38 @@ -> 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 - , storeMap = ref + { 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 = +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 +cacheLookup (Store _ _ Nothing) _ = return NotFound +cacheLookup (Store _ _ (Just lru)) key = do res <- Lru.lookup key lru return $ case res of Nothing -> NotFound @@ -108,15 +120,15 @@ -------------------------------------------------------------------------------- cacheIsMember :: Store -> String -> IO Bool -cacheIsMember (Store _ Nothing) _ = return False -cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru +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 +cacheDelete (Store _ _ Nothing) _ = return () +cacheDelete (Store _ _ (Just lru)) key = do _ <- Lru.delete key lru return () @@ -124,39 +136,65 @@ -------------------------------------------------------------------------------- -- | Store an item set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO () -set store identifier value = do - encodeFile (storeDirectory store key) value +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 - where - key = hash identifier + -- 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 :: (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 +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 - key = hash identifier - path = storeDirectory store key - -- 'decodeFile' from Data.Binary which closes the file ASAP - decodeClose = do + decodeClose path = do h <- openFile path ReadMode lbs <- BL.hGetContents h BL.length lbs `seq` hClose h @@ -166,32 +204,30 @@ -------------------------------------------------------------------------------- -- | 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 +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 identifier = do +delete store = withStore store "delete" $ \key path -> do cacheDelete store key - deleteFile $ storeDirectory store key - where - key = hash identifier + deleteFile path -------------------------------------------------------------------------------- -- | Delete a file unless it doesn't exist... deleteFile :: FilePath -> IO () -deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile +deleteFile = (`catchIOError` \_ -> return ()) . removeFile -------------------------------------------------------------------------------- -- | Mostly meant for internal usage hash :: [String] -> String -hash = concatMap (printf "%02x") . B.unpack . - MD5.hash . T.encodeUtf8 . T.pack . intercalate "/" +hash = show . DH.hash . intercalate "/" diff --git a/lib/Hakyll/Core/UnixFilter.hs b/lib/Hakyll/Core/UnixFilter.hs --- a/lib/Hakyll/Core/UnixFilter.hs +++ b/lib/Hakyll/Core/UnixFilter.hs @@ -92,7 +92,8 @@ ExitSuccess -> return output ExitFailure e -> fail $ "Hakyll.Core.UnixFilter.unixFilterWith: " ++ - unwords (programName : args) ++ " gave exit code " ++ show e + unwords (programName : args) ++ " gave exit code " ++ show e ++ + ". (Error: " ++ err ++ ")" -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Core/Util/File.hs b/lib/Hakyll/Core/Util/File.hs --- a/lib/Hakyll/Core/Util/File.hs +++ b/lib/Hakyll/Core/Util/File.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | A module containing various file utility functions module Hakyll.Core.Util.File ( makeDirectories , getRecursiveContents , removeDirectory + , withPermissions ) where -------------------------------------------------------------------------------- -import Control.Monad (filterM, forM, when) -import System.Directory (createDirectoryIfMissing, - doesDirectoryExist, getDirectoryContents, - removeDirectoryRecursive) +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 -------------------------------------------------------------------------------- @@ -24,33 +36,79 @@ -------------------------------------------------------------------------------- -- | 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 + -> 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 - go dir = do - dirExists <- doesDirectoryExist (top dir) + 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 <- filterM isProper =<< getDirectoryContents (top dir) - paths <- forM names $ \name -> do - let rel = dir name - isDirectory <- doesDirectoryExist (top rel) + names <- getProperDirectoryContents absDir + fmap concat . forM names $ \name -> do + let relPath = relDir name + absPath = top relPath + isDirectory <- doesDirectoryExist absPath if isDirectory - then go rel - else return [rel] - - return $ concat paths + 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 diff --git a/lib/Hakyll/Core/Util/Parser.hs b/lib/Hakyll/Core/Util/Parser.hs --- a/lib/Hakyll/Core/Util/Parser.hs +++ b/lib/Hakyll/Core/Util/Parser.hs @@ -2,7 +2,6 @@ -- | Parser utilities module Hakyll.Core.Util.Parser ( metadataKey - , reservedKeys ) where diff --git a/lib/Hakyll/Core/Util/String.hs b/lib/Hakyll/Core/Util/String.hs --- a/lib/Hakyll/Core/Util/String.hs +++ b/lib/Hakyll/Core/Util/String.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | Miscellaneous string manipulation functions. module Hakyll.Core.Util.String @@ -6,13 +6,13 @@ , replaceAll , splitAll , needlePrefix + , removeWinPathSeparator ) where -------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.List (isPrefixOf) -import Data.Maybe (listToMaybe) import Text.Regex.TDFA ((=~~)) @@ -27,17 +27,15 @@ -------------------------------------------------------------------------------- -- | A simple (but inefficient) regex replace funcion replaceAll :: String -- ^ Pattern - -> (String -> String) -- ^ Replacement (called on capture) + -> (String -> String) -- ^ Replacement (called on match) -> 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 + replaceAll' "" = "" + replaceAll' src = case src =~~ pattern of + Nothing -> src + Just (before, capture, after) -> before ++ f capture ++ replaceAll' after -------------------------------------------------------------------------------- @@ -48,11 +46,10 @@ -> [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) + splitAll' "" = [] + splitAll' src = case src =~~ pattern of + Nothing -> [src] + Just (before, _::String, after) -> before : splitAll' after @@ -76,3 +73,9 @@ 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]) diff --git a/lib/Hakyll/Main.hs b/lib/Hakyll/Main.hs --- a/lib/Hakyll/Main.hs +++ b/lib/Hakyll/Main.hs @@ -1,12 +1,23 @@ -------------------------------------------------------------------------------- -- | Module providing the main hakyll function and command-line argument parsing -{-# LANGUAGE CPP #-} - module Hakyll.Main - ( hakyll + ( -- * Entry points + hakyll , hakyllWith , hakyllWithArgs , hakyllWithExitCode + , hakyllWithExitCodeAndArgs + + -- * Command line argument parsers + , Options(..) + , Command(..) + , optionParser + , commandParser + , defaultCommands + , defaultParser + , defaultParserPure + , defaultParserPrefs + , defaultParserInfo ) where @@ -17,7 +28,6 @@ -------------------------------------------------------------------------------- -import Data.Monoid ((<>)) import qualified Options.Applicative as OA @@ -27,6 +37,7 @@ import qualified Hakyll.Core.Configuration as Config import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Rules +import Hakyll.Core.Runtime -------------------------------------------------------------------------------- @@ -69,19 +80,32 @@ -------------------------------------------------------------------------------- defaultParser :: Config.Configuration -> IO Options defaultParser conf = - OA.customExecParser (OA.prefs OA.showHelpOnError) - (OA.info (OA.helper <*> optionParser conf) - (OA.fullDesc <> OA.progDesc - (progName ++ " - Static site compiler created with Hakyll"))) + 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 -> Commands.build conf logger rules - Check _ -> Commands.check conf logger check >> ok + 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 @@ -94,20 +118,32 @@ -------------------------------------------------------------------------------- +-- | The parsed command-line options. data Options = Options {verbosity :: Bool, optCommand :: Command} deriving (Show) +-- | The command to run. data Command - = Build + = 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 @@ -115,47 +151,49 @@ commandParser :: Config.Configuration -> OA.Parser Command -commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty commands +commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty (defaultCommands conf) 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)) - produceCommand (c,a,b) = OA.command c (OA.info (OA.helper <*> a) (b)) - commands = - [ ( "build" - , pure Build - , 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." - ) - ] + +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)) -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Preview/Poll.hs b/lib/Hakyll/Preview/Poll.hs --- a/lib/Hakyll/Preview/Poll.hs +++ b/lib/Hakyll/Preview/Poll.hs @@ -14,12 +14,11 @@ import Control.Monad (forever, void, when) import System.Directory (canonicalizePath) import System.FilePath (pathSeparators) -import System.FSNotify (Event (..), startManager, - watchTree) +import qualified System.FSNotify as FSNotify #ifdef mingw32_HOST_OS import Control.Concurrent (threadDelay) -import Control.Exception (IOException, throw, try) +import Control.Exception (IOException, try) import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.FilePath (()) @@ -43,18 +42,18 @@ let providerDir = providerDirectory conf shouldBuild <- newEmptyMVar pattern <- update - fullProviderDir <- canonicalizePath $ providerDirectory conf - manager <- startManager + 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 = eventPath event + let path = FSNotify.eventPath event relative = dropWhile (`elem` pathSeparators) $ drop (length fullProviderDir) path identifier = fromFilePath relative - - shouldIgnore <- shouldIgnoreFile conf path + shouldIgnore <- checkIgnore path return $ not shouldIgnore && matches pattern identifier -- This thread continually watches the `shouldBuild` MVar and builds @@ -69,7 +68,7 @@ -- Send an event whenever something occurs so that the thread described -- above will do a build. - void $ watchTree manager providerDir (not . isRemove) $ \event -> do + void $ FSNotify.watchTree manager providerDir (not . isRemove) $ \event -> do allowed' <- allowed event when allowed' $ void $ tryPutMVar shouldBuild event where @@ -77,7 +76,7 @@ update' _ _ = void update #else update' event provider = do - let path = provider eventPath event + let path = provider FSNotify.eventPath event -- on windows, a 'Modified' event is also sent on file deletion fileExists <- doesFileExist path @@ -105,15 +104,6 @@ -------------------------------------------------------------------------------- -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 +isRemove :: FSNotify.Event -> Bool +isRemove (FSNotify.Removed {}) = True +isRemove _ = False diff --git a/lib/Hakyll/Preview/Server.hs b/lib/Hakyll/Preview/Server.hs --- a/lib/Hakyll/Preview/Server.hs +++ b/lib/Hakyll/Preview/Server.hs @@ -18,14 +18,14 @@ import qualified Hakyll.Core.Logger as Logger staticServer :: Logger -- ^ Logger - -> FilePath -- ^ Directory to serve + -> Static.StaticSettings -- ^ Static file server settings -> String -- ^ Host to bind on -> Int -- ^ Port to listen on -> IO () -- ^ Blocks forever -staticServer logger directory host port = do +staticServer logger settings host port = do Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port - Warp.runSettings warpSettings $ - Static.staticApp (Static.defaultFileServerSettings directory) + 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) diff --git a/lib/Hakyll/Web/CompressCss.hs b/lib/Hakyll/Web/CompressCss.hs --- a/lib/Hakyll/Web/CompressCss.hs +++ b/lib/Hakyll/Web/CompressCss.hs @@ -8,12 +8,14 @@ -------------------------------------------------------------------------------- -import Data.List (isPrefixOf) +import Data.Char (isSpace) +import Data.List (dropWhileEnd, isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item +import Hakyll.Core.Util.String -------------------------------------------------------------------------------- @@ -25,62 +27,79 @@ -------------------------------------------------------------------------------- -- | Compress CSS to speed up your site. compressCss :: String -> String -compressCss = compressSeparators . stripComments . compressWhitespace +compressCss = withoutStrings (handleCalcExpressions compressSeparators . compressWhitespace) + . dropWhileEnd isSpace + . dropWhile isSpace + . stripComments -------------------------------------------------------------------------------- -- | Compresses certain forms of separators. compressSeparators :: String -> String -compressSeparators [] = [] -compressSeparators str - | isConstant = head str : retainConstants compressSeparators (head str) (drop 1 str) - | stripFirst = compressSeparators (drop 1 str) - | stripSecond = compressSeparators (head str : (drop 2 str)) - | otherwise = head str : compressSeparators (drop 1 str) +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 - isConstant = or $ map (isOfPrefix str) ["\"", "'"] - stripFirst = or $ map (isOfPrefix str) $ [";;", ";}"] ++ (map (\c -> " " ++ c) separators) - stripSecond = or $ map (isOfPrefix str) $ map (\c -> c ++ " ") separators - separators = [" ", "{", "}", ":", ";", ",", ">", "+", "!"] + 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 [] = [] -compressWhitespace str - | isConstant = head str : retainConstants compressWhitespace (head str) (drop 1 str) - | replaceOne = compressWhitespace (' ' : (drop 1 str)) - | replaceTwo = compressWhitespace (' ' : (drop 2 str)) - | otherwise = head str : compressWhitespace (drop 1 str) - where - isConstant = or $ map (isOfPrefix str) ["\"", "'"] - replaceOne = or $ map (isOfPrefix str) ["\t", "\n", "\r"] - replaceTwo = or $ map (isOfPrefix str) [" \t", " \n", " \r", " "] +compressWhitespace = replaceAll "[ \t\n\r]+" (const " ") -------------------------------------------------------------------------------- --- | Function that strips CSS comments away. +-- | Function that strips CSS comments away (outside of strings). stripComments :: String -> String -stripComments [] = [] -stripComments str - | isConstant = head str : retainConstants stripComments (head str) (drop 1 str) - | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str - | otherwise = head str : stripComments (drop 1 str) - where - isConstant = or $ map (isOfPrefix str) ["\"", "'"] - eatComments str' - | null str' = [] - | isPrefixOf "*/" str' = drop 2 str' - | otherwise = eatComments $ drop 1 str' +stripComments "" = "" +stripComments ('/':'*':str) = stripComments $ eatComment str +stripComments (x:xs) | x `elem` "\"'" = retainString x xs stripComments + | otherwise = x : stripComments xs --------------------------------------------------------------------------------- --- | Helper function to handle string constants correctly. -retainConstants :: (String -> String) -> Char -> String -> String -retainConstants f delim str - | null str = [] - | isPrefixOf [delim] str = head str : f (drop 1 str) - | otherwise = head str : retainConstants f delim (drop 1 str) +eatComment :: String -> String +eatComment "" = "" +eatComment ('*':'/':str) = str +eatComment (_:str) = eatComment str + -------------------------------------------------------------------------------- --- | Helper function to determine whether a string is a substring. -isOfPrefix :: String -> String -> Bool -isOfPrefix = flip isPrefixOf +-- | 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 diff --git a/lib/Hakyll/Web/Feed.hs b/lib/Hakyll/Web/Feed.hs --- a/lib/Hakyll/Web/Feed.hs +++ b/lib/Hakyll/Web/Feed.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + -------------------------------------------------------------------------------- -- | A Module that allows easy rendering of RSS feeds. -- @@ -16,28 +19,79 @@ -- -- 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 +import Hakyll.Core.Compiler.Internal (compilerThrow) import Hakyll.Core.Item -import Hakyll.Core.Util.String (replaceAll) +import Hakyll.Core.Util.String (replaceAll) import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.List -------------------------------------------------------------------------------- -import Paths_hakyll +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. @@ -46,7 +100,8 @@ feedDescription :: String , -- | Name of the feed author. feedAuthorName :: String - , -- | Email of the feed author. + , -- | 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 @@ -54,35 +109,42 @@ -------------------------------------------------------------------------------- +-- | Different types a feed can have. +data FeedType = XmlFeed | JsonFeed + deriving (Show, Eq) + + +-------------------------------------------------------------------------------- -- | Abstract function to render any feed. -renderFeed :: FilePath -- ^ Feed template - -> FilePath -- ^ Item template +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 feedPath itemPath config itemContext items = do - feedTpl <- loadTemplate feedPath - itemTpl <- loadTemplate itemPath +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 -> ", " - protectedItems <- mapM (applyFilter protectCDATA) items - body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems + 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 "]]>") - -- Auxiliary: load a template from a datafile - loadTemplate path = do - file <- compilerUnsafeIO $ getDataFileName path - unsafeReadTemplateFile file itemContext' = mconcat - [ itemContext + [ escapeDescription itemContext , constField "root" (feedRoot config) , constField "authorName" (feedAuthorName config) - , constField "authorEmail" (feedAuthorEmail config) + , emailField ] feedContext = mconcat @@ -90,7 +152,7 @@ , constField "title" (feedTitle config) , constField "description" (feedDescription config) , constField "authorName" (feedAuthorName config) - , constField "authorEmail" (feedAuthorEmail config) + , emailField , constField "root" (feedRoot config) , urlField "url" , updatedField @@ -102,34 +164,200 @@ 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 + _ -> 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 = renderFeed - "templates/rss.xml" "templates/rss-item.xml" config - (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context) +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 = renderFeed - "templates/atom.xml" "templates/atom-item.xml" config - (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context) +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 - [dateField "published" fmt, context, dateField "updated" fmt] + [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" diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs --- a/lib/Hakyll/Web/Html.hs +++ b/lib/Hakyll/Web/Html.hs @@ -3,9 +3,12 @@ module Hakyll.Web.Html ( -- * Generic withTags + , withTagList + , withTagListM -- * Headers , demoteHeaders + , demoteHeadersBy -- * Url manipulation , getUrls @@ -21,34 +24,59 @@ -------------------------------------------------------------------------------- +import Control.Monad (void) +import Control.Monad.Identity (Identity(runIdentity)) import Data.Char (digitToInt, intToDigit, isDigit, toLower) -import Data.List (isPrefixOf) +import Data.Either (fromRight) +import Data.List (isPrefixOf, intercalate) +import Data.Maybe (fromMaybe) import qualified Data.Set as S -import System.FilePath.Posix (joinPath, splitPath, +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 f = renderTags' . map f . parseTags' +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 = withTags $ \tag -> case tag of +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 + 1)] + | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)] | otherwise = t demote t = t @@ -59,8 +87,17 @@ -------------------------------------------------------------------------------- +-- | Extract URLs from tags' attributes. Those would be the same URLs on which +-- `withUrls` would act. getUrls :: [TS.Tag String] -> [String] -getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k] +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 = [] -------------------------------------------------------------------------------- @@ -70,6 +107,14 @@ 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) @@ -112,7 +157,7 @@ -- -- This also sanitizes the URL, e.g. converting spaces into '%20' toUrl :: FilePath -> String -toUrl url = case url of +toUrl url = case (removeWinPathSeparator url) of ('/' : xs) -> '/' : sanitize xs xs -> '/' : sanitize xs where @@ -126,8 +171,8 @@ -------------------------------------------------------------------------------- -- | 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 +toSiteRoot = removeWinPathSeparator . emptyException . joinPath + . map parent . filter relevant . splitPath . takeDirectory where parent = const ".." emptyException [] = "." @@ -182,3 +227,83 @@ -- > "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 "" diff --git a/lib/Hakyll/Web/Meta/JSONLD.hs b/lib/Hakyll/Web/Meta/JSONLD.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/JSONLD.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + +JSON-LD metadata, using 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: + +@ +\ + \$title$\ + \ + $if(jsonld)$$jsonld("embed")$$endif$ +\ +@ + +The @"embed"@ argument generates a @\" + >>= compileTemplateItem diff --git a/lib/Hakyll/Web/Meta/OpenGraph.hs b/lib/Hakyll/Web/Meta/OpenGraph.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/OpenGraph.hs @@ -0,0 +1,71 @@ +{- | + +Open Graph metadata, as described at . 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: + +@ +\ + \$title$ + \ + $if(opengraph)$$opengraph$$endif$ +\ +@ + +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 = + "\ + \\ + \\ + \$if(og-description)$\ + \\ + \$endif$\ + \$if(og-image)$\ + \\ + \$endif$\ + \" diff --git a/lib/Hakyll/Web/Meta/TwitterCard.hs b/lib/Hakyll/Web/Meta/TwitterCard.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/TwitterCard.hs @@ -0,0 +1,63 @@ +{- | + +Twitter Card metadata, as described at +. +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: + +@ +\ + \$title$\ + \ + $if(opengraph)$$opengraph$$endif$ + $if(twitter)$$twitter$$endif$ +\ +@ + +-} +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 = + "\ + \$if(twitter-creator)$$endif$\ + \$if(twitter-site)$$endif$" diff --git a/lib/Hakyll/Web/Paginate.hs b/lib/Hakyll/Web/Paginate.hs --- a/lib/Hakyll/Web/Paginate.hs +++ b/lib/Hakyll/Web/Paginate.hs @@ -19,6 +19,7 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item @@ -68,7 +69,7 @@ return Paginate { paginateMap = M.fromList (zip [1 ..] idGroups) , paginateMakeId = makeId - , paginateDependency = PatternDependency pattern idsSet + , paginateDependency = contentDependency $ PatternDependency pattern idsSet } diff --git a/lib/Hakyll/Web/Pandoc.hs b/lib/Hakyll/Web/Pandoc.hs --- a/lib/Hakyll/Web/Pandoc.hs +++ b/lib/Hakyll/Web/Pandoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | Module exporting convenient pandoc bindings module Hakyll.Web.Pandoc @@ -8,12 +9,16 @@ , writePandocWith , renderPandoc , renderPandocWith + , renderPandocWithTransform + , renderPandocWithTransformM + , renderPandocItemWithTransformM -- * Derived compilers , pandocCompiler , pandocCompilerWith , pandocCompilerWithTransform , pandocCompilerWithTransformM + , pandocItemCompilerWithTransformM -- * Default options , defaultHakyllReaderOptions @@ -22,9 +27,9 @@ -------------------------------------------------------------------------------- -import qualified Data.Set as S +import qualified Data.Text as T import Text.Pandoc -import Text.Pandoc.Error (PandocError (..)) +import Text.Pandoc.Highlighting (pygments) -------------------------------------------------------------------------------- @@ -48,28 +53,38 @@ -> 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 $ + 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' + 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 = S.insert e $ readerExtensions ro} + addExt ro e = ro {readerExtensions = enableExtension e $ readerExtensions ro} -------------------------------------------------------------------------------- @@ -84,7 +99,10 @@ writePandocWith :: WriterOptions -- ^ Writer options for pandoc -> Item Pandoc -- ^ Document to write -> Item String -- ^ Resulting HTML -writePandocWith wopt = fmap $ writeHtmlString wopt +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' -------------------------------------------------------------------------------- @@ -103,6 +121,51 @@ -------------------------------------------------------------------------------- +-- | 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 = @@ -137,17 +200,30 @@ -> (Pandoc -> Compiler Pandoc) -> Compiler (Item String) pandocCompilerWithTransformM ropt wopt f = - writePandocWith wopt <$> - (traverse f =<< readPandocWith ropt =<< getResourceBody) + 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. - readerSmart = True + readerExtensions = enableExtension Ext_smart pandocExtensions } @@ -157,8 +233,21 @@ 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) + writerExtensions = enableExtension Ext_smart pandocExtensions , -- We want to have hightlighting by default, to be compatible with earlier -- Hakyll releases - writerHighlight = True +#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 } diff --git a/lib/Hakyll/Web/Pandoc/Biblio.hs b/lib/Hakyll/Web/Pandoc/Biblio.hs --- a/lib/Hakyll/Web/Pandoc/Biblio.hs +++ b/lib/Hakyll/Web/Pandoc/Biblio.hs @@ -6,49 +6,64 @@ -- 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. +-- '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. +-- 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 + ( CSL (..) , cslCompiler , Biblio (..) , biblioCompiler , readPandocBiblio + , readPandocBiblios + , processPandocBiblio + , processPandocBiblios , pandocBiblioCompiler + , pandocBibliosCompiler ) where -------------------------------------------------------------------------------- -import Control.Monad (liftM, replicateM) -import Data.Binary (Binary (..)) -import Data.Default (def) -import Data.Typeable (Typeable) +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 Hakyll.Web.Pandoc.Binary () -import qualified Text.CSL as CSL -import Text.CSL.Pandoc (processCites) -import Text.Pandoc (Pandoc, ReaderOptions (..)) +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) -------------------------------------------------------------------------------- -data CSL = CSL - deriving (Show, Typeable) +newtype CSL = CSL {unCSL :: B.ByteString} + deriving (Binary, Show, Typeable) --------------------------------------------------------------------------------- -instance Binary CSL where - put CSL = return () - get = return CSL - -------------------------------------------------------------------------------- instance Writable CSL where -- Shouldn't be written. @@ -57,21 +72,12 @@ -------------------------------------------------------------------------------- cslCompiler :: Compiler (Item CSL) -cslCompiler = makeItem CSL - - --------------------------------------------------------------------------------- -newtype Biblio = Biblio [CSL.Reference] - deriving (Show, Typeable) +cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS -------------------------------------------------------------------------------- -instance Binary Biblio where - -- Ugly. - get = do - len <- get - Biblio <$> replicateM len get - put (Biblio rs) = put (length rs) >> mapM_ put rs +newtype Biblio = Biblio {unBiblio :: B.ByteString} + deriving (Binary, Show, Typeable) -------------------------------------------------------------------------------- @@ -82,9 +88,7 @@ -------------------------------------------------------------------------------- biblioCompiler :: Compiler (Item Biblio) -biblioCompiler = do - filePath <- toFilePath <$> getUnderlying - makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath) +biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS -------------------------------------------------------------------------------- @@ -93,23 +97,144 @@ -> 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 +readPandocBiblio ropt csl biblio = readPandocBiblios ropt csl [biblio] - -- 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 +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 - return $ fmap (const pandoc') item -------------------------------------------------------------------------------- + +-- | Process a bibliography file with the given style. +-- +-- This function supports pandoc's +-- +-- 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 def csl bib) + (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 + } diff --git a/lib/Hakyll/Web/Pandoc/Binary.hs b/lib/Hakyll/Web/Pandoc/Binary.hs --- a/lib/Hakyll/Web/Pandoc/Binary.hs +++ b/lib/Hakyll/Web/Pandoc/Binary.hs @@ -4,9 +4,6 @@ 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 -------------------------------------------------------------------------------- @@ -14,7 +11,10 @@ instance Binary Alignment instance Binary Block -instance Binary CSL.Reference +instance Binary Caption +instance Binary Cell +instance Binary ColSpan +instance Binary ColWidth instance Binary Citation instance Binary CitationMode instance Binary Format @@ -23,10 +23,9 @@ instance Binary ListNumberStyle instance Binary MathType instance Binary QuoteType -instance Binary REF.CLabel -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 Row +instance Binary RowHeadColumns +instance Binary RowSpan +instance Binary TableBody +instance Binary TableFoot +instance Binary TableHead diff --git a/lib/Hakyll/Web/Pandoc/FileType.hs b/lib/Hakyll/Web/Pandoc/FileType.hs --- a/lib/Hakyll/Web/Pandoc/FileType.hs +++ b/lib/Hakyll/Web/Pandoc/FileType.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | A module dealing with pandoc file extensions and associated file types module Hakyll.Web.Pandoc.FileType @@ -24,6 +25,7 @@ | Css | DocBook | Html + | Jupyter | LaTeX | LiterateHaskell FileType | Markdown @@ -32,6 +34,17 @@ | 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) @@ -42,6 +55,7 @@ where fileType' _ ".css" = Css fileType' _ ".dbk" = DocBook + fileType' _ ".ipynb" = Jupyter fileType' _ ".htm" = Html fileType' _ ".html" = Html fileType' f ".lhs" = LiterateHaskell $ case fileType f of @@ -64,6 +78,19 @@ 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 diff --git a/lib/Hakyll/Web/Redirect.hs b/lib/Hakyll/Web/Redirect.hs --- a/lib/Hakyll/Web/Redirect.hs +++ b/lib/Hakyll/Web/Redirect.hs @@ -6,9 +6,9 @@ , createRedirects ) where -import Control.Applicative ((<$>)) -import Control.Monad (forM_) +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 @@ -55,6 +55,17 @@ -- See also . 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 @@ -81,6 +92,7 @@ redirectToHtml :: Redirect -> String redirectToHtml (Redirect working) = "" ++ + "" ++ "Permanent Redirect

The page has moved to: Identifier -> m [String] -getTags identifier = do +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 "tags" metadata) `mplus` - (map trim . splitAll "," <$> lookupString "tags" metadata) + (lookupStringList fieldName metadata) `mplus` + (map trim . splitAll "," <$> lookupString fieldName metadata) -------------------------------------------------------------------------------- --- | Obtain categories from a page. +-- | Obtain category from a page. getCategory :: MonadMetadata m => Identifier -> m [String] getCategory = return . return . takeBaseName . takeDirectory . toFilePath @@ -128,7 +136,8 @@ ids <- getMatches pattern tagMap <- foldM addTags M.empty ids let set' = S.fromList ids - return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set') + return $ Tags (M.toList tagMap) makeId + (metadataDependency $ PatternDependency pattern set') where -- Create a tag map for one page addTags tagMap id' = do @@ -276,7 +285,7 @@ renderTagList = renderTags makeLink (intercalate ", ") where makeLink tag url count _ _ = renderHtml $ - H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")") + H.a ! A.href (toValue url) ! A.rel "tag" $ toHtml (tag ++ " (" ++ show count ++ ")") -------------------------------------------------------------------------------- @@ -325,8 +334,11 @@ -- | 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 +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 -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Web/Template.hs b/lib/Hakyll/Web/Template.hs --- a/lib/Hakyll/Web/Template.hs +++ b/lib/Hakyll/Web/Template.hs @@ -138,6 +138,7 @@ -- > 3...2...1 -- >

-- +{-# LANGUAGE TemplateHaskell #-} module Hakyll.Web.Template ( Template , templateBodyCompiler @@ -146,9 +147,32 @@ , 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 |] diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs --- a/lib/Hakyll/Web/Template/Context.hs +++ b/lib/Hakyll/Web/Template/Context.hs @@ -1,3 +1,23 @@ +-- | 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 #-} @@ -6,11 +26,13 @@ , Context (..) , field , boolField + , boolFieldM , constField , listField , listFieldWith , functionField , mapContext + , mapContextBy , defaultContext , bodyField @@ -32,28 +54,34 @@ -------------------------------------------------------------------------------- -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 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.Core.Util.String (needlePrefix, splitAll) import Hakyll.Web.Html -import System.FilePath (splitDirectories, takeBaseName) - +import Prelude hiding (id) +import System.FilePath (dropExtension, splitDirectories, + takeBaseName) -------------------------------------------------------------------------------- -- | Mostly for internal usage data ContextField - = StringField String + = EmptyField + | StringField String | forall a. ListField (Context a) [Item a] @@ -78,71 +106,155 @@ -------------------------------------------------------------------------------- +-- | 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 (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i + 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 empty +field' key value = Context $ \k _ i -> + if k == key + then value i + else noResult $ "Tried field " ++ key -------------------------------------------------------------------------------- --- | Constructs a new field in the 'Context.' +-- | 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 + -- 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 - -> (Item a -> Bool) + :: String -- ^ Key + -> (Item a -> Bool) -- ^ Extract value from an @'Item' a@ -> Context a -boolField name f = field name (\i -> if f i - then pure (error $ unwords ["no string value for bool field:",name]) - else empty) +boolField name f = boolFieldM name (pure . f) -------------------------------------------------------------------------------- --- | Creates a 'field' that does not depend on the 'Item' -constField :: String -> String -> Context a +-- | 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 -------------------------------------------------------------------------------- -functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a +-- | 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 empty + 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 f (Context c) = Context $ \k a i -> do +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 - StringField str -> return $ StringField (f str) - ListField _ _ -> fail $ - "Hakyll.Web.Template.Context.mapContext: " ++ - "can't map over a ListField!" + 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: @@ -151,20 +263,20 @@ -- > $snippet("path/to/snippet/")$ -- > ... -- --- The contents of the included file will not be interpolated. +-- 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 _ i = error $ - "Too many arguments to function 'snippet()' in item " ++ - show (itemIdentifier i) + 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$@ field +-- 1. A @$body$@ 'bodyField' -- -- 2. Metadata fields -- @@ -173,14 +285,24 @@ -- 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" `mappend` - missingField + titleField "title" -------------------------------------------------------------------------------- @@ -189,7 +311,7 @@ -------------------------------------------------------------------------------- --- | Constructs a 'field' that contains the body of the item. +-- | Body of the item, that is, the main content of the underlying file bodyField :: String -> Context String bodyField key = field key $ return . itemBody @@ -198,25 +320,34 @@ -- | 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 + 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 +-- | 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 $ - fmap (maybe empty toUrl) . getRoute . itemIdentifier +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 +-- | 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 -------------------------------------------------------------------------------- --- | This title 'field' takes the basename of the underlying file by default +-- | 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 @@ -248,6 +379,8 @@ -- -- * @2010-09-06@ -- +-- * @06.09.2010@ +-- -- * @September 06, 2010@ -- -- Alternatively, when the metadata has a field called @path@ in a @@ -257,6 +390,12 @@ -- 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 @@ -267,7 +406,7 @@ -------------------------------------------------------------------------------- -- | 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'. +-- details, see 'dateField' and 'formatTime'. dateFieldWith :: TimeLocale -- ^ Output time locale -> String -- ^ Destination key -> String -- ^ Format to use on the date @@ -281,28 +420,33 @@ -- | 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 +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 $ toFilePath id' + 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 "-" $ 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" @@ -321,13 +465,16 @@ -------------------------------------------------------------------------------- +-- | Creates a field with the last modification date of the underlying item. modificationTimeField :: String -- ^ Key -> String -- ^ Format - -> Context a -- ^ Resuting context + -> 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 @@ -366,14 +513,8 @@ -------------------------------------------------------------------------------- +-- | 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 _ 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 +missingField = Context $ \k _ _ -> noResult $ + "Missing field '" ++ k ++ "' in context" diff --git a/lib/Hakyll/Web/Template/Internal.hs b/lib/Hakyll/Web/Template/Internal.hs --- a/lib/Hakyll/Web/Template/Internal.hs +++ b/lib/Hakyll/Web/Template/Internal.hs @@ -1,15 +1,18 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} + module Hakyll.Web.Template.Internal ( Template (..) , template , templateBodyCompiler , templateCompiler , applyTemplate - , applyTemplate' , loadAndApplyTemplate , applyAsTemplate , readTemplate + , compileTemplateItem , unsafeReadTemplateFile , module Hakyll.Web.Template.Internal.Element @@ -18,16 +21,18 @@ -------------------------------------------------------------------------------- -import Control.Monad.Except (MonadError (..)) +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 Prelude hiding (id) +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 @@ -38,9 +43,10 @@ -------------------------------------------------------------------------------- -- | Datatype used for template substitutions. -newtype Template = Template - { unTemplate :: [TemplateElement] - } deriving (Show, Eq, Binary, Typeable) +data Template = Template + { tplElements :: [TemplateElement] + , tplOrigin :: FilePath -- Only for error messages. + } deriving (Show, Eq, Generic, Binary, Typeable) -------------------------------------------------------------------------------- @@ -56,41 +62,70 @@ -------------------------------------------------------------------------------- -- | Wrap the constructor to ensure trim is called. -template :: [TemplateElement] -> Template -template = Template . trim +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 = Template . trim . readTemplateElems +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 <- getResourceFilePath - return $ fmap (template . readTemplateElemsFile file) item + 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 <- getResourceFilePath - return $ fmap (template . readTemplateElemsFile file) item + 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' (unTemplate tpl) context item + 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. @@ -105,9 +140,6 @@ go = fmap concat . mapM applyElem - trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++ - "fully trimmed." - --------------------------------------------------------------------------- applyElem :: TemplateElement -> Compiler String @@ -118,29 +150,43 @@ applyElem (Chunk c) = return c - applyElem (Expr e) = applyExpr e >>= getString e + 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) = (applyExpr e >> go t) `catchError` handler + applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle where - handler _ = case mf of - Nothing -> return "" - Just f -> go f + 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) = 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 + 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) = do - p <- applyExpr e >>= getString e - Template tpl' <- loadBody (fromFilePath p) - applyTemplate' tpl' context x + 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 ++ ")$'" --------------------------------------------------------------------------- @@ -149,19 +195,31 @@ applyExpr (Ident (TemplateKey k)) = context' k [] x applyExpr (Call (TemplateKey k) args) = do - args' <- mapM (\e -> applyExpr e >>= getString e) args + args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args context' k args' x + where + typeMsg e = "argument '" ++ show e ++ "'" 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 + 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: -- @@ -189,15 +247,14 @@ applyAsTemplate :: Context String -- ^ Context -> Item String -- ^ Item and template -> Compiler (Item String) -- ^ Resulting item -applyAsTemplate context item = - let tpl = template $ readTemplateElemsFile file (itemBody item) - file = toFilePath $ itemIdentifier item - in applyTemplate tpl context item +applyAsTemplate context item = do + tpl <- compileTemplateItem item + applyTemplate tpl context item -------------------------------------------------------------------------------- unsafeReadTemplateFile :: FilePath -> Compiler Template unsafeReadTemplateFile file = do tpl <- unsafeCompiler $ readFile file - pure $ template $ readTemplateElemsFile file tpl - + compileTemplateFile (fromFilePath file) tpl +{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-} diff --git a/lib/Hakyll/Web/Template/Internal/Element.hs b/lib/Hakyll/Web/Template/Internal/Element.hs --- a/lib/Hakyll/Web/Template/Internal/Element.hs +++ b/lib/Hakyll/Web/Template/Internal/Element.hs @@ -7,14 +7,14 @@ , TemplateExpr (..) , TemplateElement (..) , templateElems - , readTemplateElems - , readTemplateElemsFile + , 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) @@ -107,17 +107,10 @@ 2 -> StringLiteral <$> get _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" - -------------------------------------------------------------------------------- -readTemplateElems :: String -> [TemplateElement] -readTemplateElems = readTemplateElemsFile "{literal}" - - --------------------------------------------------------------------------------- -readTemplateElemsFile :: FilePath -> String -> [TemplateElement] -readTemplateElemsFile file input = case P.parse templateElems file input of - Left err -> error $ "Cannot parse template: " ++ show err - Right t -> t +parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement] +parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e) + . P.parse (templateElems <* P.eof) file -------------------------------------------------------------------------------- @@ -167,7 +160,7 @@ -------------------------------------------------------------------------------- trimClose :: P.Parser Bool trimClose = do - trimIfR <- P.optionMaybe $ P.try (P.char '-') + trimIfR <- P.optionMaybe $ (P.char '-') void $ P.char '$' pure $ isJust trimIfR diff --git a/lib/Hakyll/Web/Template/List.hs b/lib/Hakyll/Web/Template/List.hs --- a/lib/Hakyll/Web/Template/List.hs +++ b/lib/Hakyll/Web/Template/List.hs @@ -7,6 +7,7 @@ -- * An image list in a gallery -- -- * A sitemap +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module Hakyll.Web.Template.List ( applyTemplateList @@ -20,6 +21,9 @@ -------------------------------------------------------------------------------- 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) @@ -60,7 +64,7 @@ -------------------------------------------------------------------------------- -- | Sort pages chronologically. Uses the same method as 'dateField' for -- extracting the date. -chronological :: MonadMetadata m => [Item a] -> m [Item a] +chronological :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a] chronological = sortByM $ getItemUTC defaultTimeLocale . itemIdentifier where @@ -71,14 +75,14 @@ -------------------------------------------------------------------------------- -- | The reverse of 'chronological' -recentFirst :: MonadMetadata m => [Item a] -> m [Item a] +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 => [Identifier] -> m [Identifier] + :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier] sortChronological ids = liftM (map itemIdentifier) $ chronological [Item i () | i <- ids] @@ -86,6 +90,6 @@ -------------------------------------------------------------------------------- -- | Version of 'recentFirst' which doesn't need the actual items. sortRecentFirst - :: MonadMetadata m => [Identifier] -> m [Identifier] + :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier] sortRecentFirst ids = liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids] diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module Main ( main ) where @@ -6,12 +7,16 @@ -------------------------------------------------------------------------------- import Control.Arrow (first) -import Control.Monad (forM_) +import Control.Monad (forM, forM_) import Data.Char (isAlphaNum, isNumber) -import Data.List (foldl') 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) +import System.Directory (canonicalizePath, copyFile, + doesFileExist, + setPermissions, getPermissions, writable) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (splitDirectories, ()) @@ -23,6 +28,10 @@ -------------------------------------------------------------------------------- +import Prelude + + +-------------------------------------------------------------------------------- main :: IO () main = do progName <- getProgName @@ -37,22 +46,49 @@ -- 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 + [dstDir] | not ("-" `isPrefixOf` dstDir) -> + createFiles False srcDir files dstDir + ["-f", dstDir] -> + createFiles True srcDir files dstDir + _ -> do + putStrLn $ "Usage: " ++ progName ++ " [-f] " + exitFailure + where + createFiles force srcDir files dstDir = do name <- makeName dstDir let cabalPath = dstDir name ++ ".cabal" - putStrLn $ "Creating " ++ cabalPath - createCabal cabalPath name - _ -> do - putStrLn $ "Usage: " ++ progName ++ " " - exitFailure + 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 @@ -77,7 +113,7 @@ safeLast = foldl' (\_ x -> Just x) Nothing createCabal :: FilePath -> String -> IO () -createCabal path name = do +createCabal path name = writeFile path $ unlines [ "name: " ++ name , "version: 0.1.0.0" @@ -88,7 +124,7 @@ , " main-is: site.hs" , " build-depends: base == 4.*" , " , hakyll == " ++ version' ++ ".*" - , " ghc-options: -threaded" + , " ghc-options: -threaded -rtsopts -with-rtsopts=-N" , " default-language: Haskell2010" ] where diff --git a/tests/Hakyll/Core/Dependencies/Tests.hs b/tests/Hakyll/Core/Dependencies/Tests.hs --- a/tests/Hakyll/Core/Dependencies/Tests.hs +++ b/tests/Hakyll/Core/Dependencies/Tests.hs @@ -22,7 +22,7 @@ -------------------------------------------------------------------------------- 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 diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs --- a/tests/Hakyll/Core/Identifier/Tests.hs +++ b/tests/Hakyll/Core/Identifier/Tests.hs @@ -6,13 +6,16 @@ -------------------------------------------------------------------------------- +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 @@ -21,27 +24,28 @@ tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests + , [ testProperty "toFilePath . fromFilePath" filepathConversionProp ] ] -------------------------------------------------------------------------------- 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" ] @@ -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 diff --git a/tests/Hakyll/Core/Provider/Metadata/Tests.hs b/tests/Hakyll/Core/Provider/Metadata/Tests.hs --- a/tests/Hakyll/Core/Provider/Metadata/Tests.hs +++ b/tests/Hakyll/Core/Provider/Metadata/Tests.hs @@ -1,12 +1,18 @@ -------------------------------------------------------------------------------- +{-# 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 @@ -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 -------------------------------------------------------------------------------- diff --git a/tests/Hakyll/Core/Provider/Tests.hs b/tests/Hakyll/Core/Provider/Tests.hs --- a/tests/Hakyll/Core/Provider/Tests.hs +++ b/tests/Hakyll/Core/Provider/Tests.hs @@ -9,7 +9,7 @@ import Hakyll.Core.Metadata import Hakyll.Core.Provider import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assert, testCase, (@=?)) +import Test.Tasty.HUnit (Assertion, testCase, (@=?)) import TestSuite.Util @@ -25,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 diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs --- a/tests/Hakyll/Core/Routes/Tests.hs +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -10,7 +10,7 @@ import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Routes -import System.FilePath (()) +import System.FilePath ((), normalise) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util @@ -46,5 +46,5 @@ store <- newTestStore provider <- newTestProvider store (route, _) <- runRoutes r provider id' - Just expected @=? route + Just (normalise expected) @=? route cleanTestEnv diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs --- a/tests/Hakyll/Core/Rules/Tests.hs +++ b/tests/Hakyll/Core/Rules/Tests.hs @@ -17,10 +17,9 @@ import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal -import Hakyll.Web.Pandoc -import System.FilePath (()) +import System.FilePath ((), normalise) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assert, (@=?)) +import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util @@ -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 diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/tests/Hakyll/Core/Runtime/Tests.hs @@ -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.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, (@?=)) +import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) -------------------------------------------------------------------------------- @@ -21,15 +24,23 @@ -------------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Hakyll.Core.Runtime.Tests" $ - fromAssertions "run" [case01, case02] +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,7 +50,7 @@ compile $ do getResourceBody >>= saveSnapshot "raw" - >>= renderPandoc + >>= renderParagraphs match (fromList ["partial.html", "partial-helper.html"]) $ compile templateCompiler @@ -67,7 +78,7 @@ lines example @?= ["

This is an example.

"] 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" @@ -75,12 +86,16 @@ 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) @@ -93,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 diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs --- a/tests/Hakyll/Core/Store/Tests.hs +++ b/tests/Hakyll/Core/Store/Tests.hs @@ -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 diff --git a/tests/Hakyll/Core/UnixFilter/Tests.hs b/tests/Hakyll/Core/UnixFilter/Tests.hs --- a/tests/Hakyll/Core/UnixFilter/Tests.hs +++ b/tests/Hakyll/Core/UnixFilter/Tests.hs @@ -1,20 +1,20 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Hakyll.Core.UnixFilter.Tests ( tests ) where -------------------------------------------------------------------------------- -import Data.List (isInfixOf) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) -import qualified Test.Tasty.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 @@ -22,24 +22,34 @@ -------------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Hakyll.Core.UnixFilter.Tests" - [ testCase "unixFilter rev" unixFilterRev - , testCase "unixFilter false" unixFilterFalse +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" ["-#"]) diff --git a/tests/Hakyll/Core/Util/String/Tests.hs b/tests/Hakyll/Core/Util/String/Tests.hs --- a/tests/Hakyll/Core/Util/String/Tests.hs +++ b/tests/Hakyll/Core/Util/String/Tests.hs @@ -22,11 +22,23 @@ ] , 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" diff --git a/tests/Hakyll/Web/CompressCss/Tests.hs b/tests/Hakyll/Web/CompressCss/Tests.hs --- a/tests/Hakyll/Web/CompressCss/Tests.hs +++ b/tests/Hakyll/Web/CompressCss/Tests.hs @@ -5,9 +5,8 @@ -------------------------------------------------------------------------------- -import Data.Char (toUpper) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assert, (@=?)) +import Test.Tasty.HUnit ((@=?)) -------------------------------------------------------------------------------- @@ -21,9 +20,9 @@ [ fromAssertions "compressCss" [ -- compress whitespace - " something something " @=? + "something something" @=? compressCss " something \n\t\r something " - -- do not compress whitespace in constants + -- do not compress whitespace in string tokens , "abc \" \t\n\r \" xyz" @=? compressCss "abc \" \t\n\r \" xyz" , "abc ' \t\n\r ' xyz" @=? @@ -31,7 +30,7 @@ -- strip comments , "before after" @=? compressCss "before /* abc { } ;; \n\t\r */ after" - -- don't strip comments inside constants + -- don't strip comments inside string tokens , "before \"/* abc { } ;; \n\t\r */\" after" @=? compressCss "before \"/* abc { } ;; \n\t\r */\" after" @@ -42,21 +41,25 @@ , "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 of constants + -- but do not compress separators inside string tokens , "\" { } ; , \"" @=? compressCss "\" { } ; , \"" - -- don't compress separators at the start or end of constants + -- don't compress separators at the start or end of string tokens , "\" }\"" @=? compressCss "\" }\"" , "\"{ \"" @=? compressCss "\"{ \"" - -- don't get irritated by the wrong constant terminator + -- don't get irritated by the wrong token delimiter , "\" ' \"" @=? compressCss "\" ' \"" , "' \" '" @=? compressCss "' \" '" - -- don't compress whitespace around separators in constants in the middle of a string + -- don't compress whitespace in the middle of a string , "abc '{ '" @=? compressCss "abc '{ '" , "abc \"{ \"" @=? compressCss "abc \"{ \"" - -- compress whitespace around colons - , "abc:xyz" @=? compressCss "abc : xyz" + -- compress whitespace after colons (but not before) + , "abc :xyz" @=? compressCss "abc : xyz" -- compress multiple semicolons , ";" @=? compressCss ";;;;;;;" ] diff --git a/tests/Hakyll/Web/Feed/Tests.hs b/tests/Hakyll/Web/Feed/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Hakyll/Web/Feed/Tests.hs @@ -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" + } diff --git a/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs --- a/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs +++ b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs @@ -35,4 +35,6 @@ , "" @=? relativizeUrlsWith "../.." "" + , "" @=? + relativizeUrlsWith "." "" ] diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs --- a/tests/Hakyll/Web/Html/Tests.hs +++ b/tests/Hakyll/Web/Html/Tests.hs @@ -7,7 +7,8 @@ -------------------------------------------------------------------------------- import Data.Char (toUpper) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assert, (@=?)) +import Test.Tasty.HUnit ((@=?)) +import qualified Text.HTML.TagSoup as TS -------------------------------------------------------------------------------- @@ -20,9 +21,37 @@ tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "

A h1 title

" @=? - demoteHeaders "

A h1 title

" + demoteHeaders "

A h1 title

" -- Assert single-step demotion + , "
A h6 title
" @=? + demoteHeaders "
A h6 title
" -- Assert maximum demotion is h6 ] + , fromAssertions "demoteHeadersBy" + [ "

A h1 title

" @=? + demoteHeadersBy 2 "

A h1 title

" + , "
A h5 title
" @=? + demoteHeadersBy 2 "
A h5 title
" -- Assert that h6 is the lowest possible demoted header. + , "

A h4 title

" @=? + demoteHeadersBy 0 "

A h4 title

" -- 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" [ "bar" @=? withUrls (map toUpper) "bar" @@ -40,10 +69,21 @@ -- Test minimizing elements , "" @=? withUrls id "" + + -- Test that URLs are extracted from img's srcset + , "" @=? + withUrls (const "foo") "" + , "" @=? + withUrls (const "bar") "" + + -- Invalid srcsets are left unchanged + , "" @=? + withUrls (const "bar") "" ] , 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" diff --git a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs @@ -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 diff --git a/tests/Hakyll/Web/Pandoc/FileType/Tests.hs b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs --- a/tests/Hakyll/Web/Pandoc/FileType/Tests.hs +++ b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs @@ -19,7 +19,8 @@ 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" diff --git a/tests/Hakyll/Web/Tags/Tests.hs b/tests/Hakyll/Web/Tags/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Hakyll/Web/Tags/Tests.hs @@ -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 diff --git a/tests/Hakyll/Web/Template/Context/Tests.hs b/tests/Hakyll/Web/Template/Context/Tests.hs --- a/tests/Hakyll/Web/Template/Context/Tests.hs +++ b/tests/Hakyll/Web/Template/Context/Tests.hs @@ -21,7 +21,7 @@ -------------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Hakyll.Core.Template.Context.Tests" +tests = testGroup "Hakyll.Web.Template.Context.Tests" [ testCase "testDateField" testDateField ] @@ -41,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 @@ -53,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" diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Hakyll.Web.Template.Tests ( tests ) where @@ -7,16 +8,17 @@ -------------------------------------------------------------------------------- import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, (@=?), - (@?=)) +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 @@ -26,20 +28,20 @@ -------------------------------------------------------------------------------- tests :: TestTree -tests = testGroup "Hakyll.Core.Template.Tests" $ concat +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" - [ [Chunk "Hello ", Expr (Call "guest" [])] - @=? readTemplateElems "Hello $guest()$" - , [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing] - @=? readTemplateElems "$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. - , [ TrimL + , Right [ TrimL , If (Ident (TemplateKey "body")) [ TrimR , Chunk "\n" @@ -55,29 +57,39 @@ ]) , TrimR ] - @=? readTemplateElems "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$" + @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$" -- 'For' trim check. - , [ TrimL + , Right [ TrimL , For (Ident (TemplateKey "authors")) [TrimR, Chunk "\n body \n", TrimL] Nothing , TrimR ] - @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$" + @=? parse "$-for(authors)-$\n body \n$-endfor-$" -- 'Partial' trim check. - , [ TrimL + , Right [ TrimL , Partial (StringLiteral "path") , TrimR ] - @=? readTemplateElems "$-partial(\"path\")-$" + @=? parse "$-partial(\"path\")-$" -- 'Expr' trim check. - , [ TrimL + , Right [ TrimL , Expr (Ident (TemplateKey "foo")) , TrimR ] - @=? readTemplateElems "$-foo-$" + @=? 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

foo

\n$endif$" ] + + , [testCase "embeddedTemplate" testEmbeddedTemplate] ] + where + parse = parseTemplateElemsFile "" -------------------------------------------------------------------------------- @@ -89,7 +101,9 @@ out <- resourceString provider outf tpl <- testCompilerDone store provider tplf templateBodyCompiler item <- testCompilerDone store provider itemf $ - pandocCompiler >>= applyTemplate (itemBody tpl) testContext + getResourceBody + >>= renderParagraphs + >>= applyTemplate (itemBody tpl) testContext out @=? itemBody item cleanTestEnv @@ -112,6 +126,8 @@ testApplyJoinTemplateList = do store <- newTestStore provider <- newTestProvider store + tpl <- testCompilerDone store provider "tpl" $ + compileTemplateItem (Item "tpl" "$body$") str <- testCompilerDone store provider "item3" $ applyJoinTemplateList ", " tpl defaultContext [i1, i2] @@ -120,4 +136,25 @@ where i1 = Item "item1" "Hello" i2 = Item "item2" "World" - tpl = readTemplate "$body$" + + +-------------------------------------------------------------------------------- +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 @?= ("

Hello, world

" ++ (newline nativeNewline)) + cleanTestEnv + where + item = Item "item1" "Hello, world" + + newline LF = "\n" + newline CRLF = "\r\n" + diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module Main ( main ) where @@ -22,9 +23,14 @@ 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 -------------------------------------------------------------------------------- @@ -43,7 +49,12 @@ , 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 ] diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs --- a/tests/TestSuite/Util.hs +++ b/tests/TestSuite/Util.hs @@ -6,14 +6,15 @@ , newTestProvider , testCompiler , testCompilerDone + , testCompilerError , testConfiguration , cleanTestEnv + , renderParagraphs ) where -------------------------------------------------------------------------------- -import Data.List (intercalate) -import Data.Monoid (mempty) +import Data.List (intercalate, isInfixOf) import qualified Data.Set as S import Test.Tasty import Test.Tasty.HUnit @@ -29,6 +30,7 @@ import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File +import Hakyll.Core.Item -------------------------------------------------------------------------------- @@ -36,7 +38,7 @@ -> [Assertion] -- ^ Cases -> [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 ..]] -------------------------------------------------------------------------------- @@ -46,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 -------------------------------------------------------------------------------- @@ -76,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 @@ -101,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 (("

"++) . (++"

")) + . lines) diff --git a/tests/data/biblio/chicago.csl b/tests/data/biblio/chicago.csl new file mode 100644 --- /dev/null +++ b/tests/data/biblio/chicago.csl @@ -0,0 +1,648 @@ + + diff --git a/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden b/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden @@ -0,0 +1,16 @@ + + + + + This page cites a paper. + + +

This page cites a paper.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden b/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden @@ -0,0 +1,16 @@ + + + + + This page cites a paper. + + +

This page cites a paper.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden b/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden @@ -0,0 +1,16 @@ + + + + + This page cites a paper. + + +

This page cites a paper.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden @@ -0,0 +1,20 @@ + + + + + This page cites a paper and a book. + + +

This page cites a paper and a book.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+

And also a book (Lipovača 2012).

+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press. +
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden @@ -0,0 +1,20 @@ + + + + + This page cites a paper and a book. + + +

This page cites a paper and a book.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+

And also a book (Lipovača 2012).

+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press. +
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden @@ -0,0 +1,20 @@ + + + + + This page cites a paper and a book. + + +

This page cites a paper and a book.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+

And also a book (Lipovača 2012).

+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press. +
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/cites-multiple.markdown b/tests/data/biblio/cites-multiple.markdown new file mode 100644 --- /dev/null +++ b/tests/data/biblio/cites-multiple.markdown @@ -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]. diff --git a/tests/data/biblio/default.html b/tests/data/biblio/default.html new file mode 100644 --- /dev/null +++ b/tests/data/biblio/default.html @@ -0,0 +1,11 @@ + + + + + $title$ + + +

$title$

+ $body$ + + diff --git a/tests/data/biblio/page.markdown b/tests/data/biblio/page.markdown new file mode 100644 --- /dev/null +++ b/tests/data/biblio/page.markdown @@ -0,0 +1,5 @@ +--- +title: This page cites a paper. +--- + +I would like to cite one of my favourite papers [@meijer1991functional] here. diff --git a/tests/data/biblio/refs.bib b/tests/data/biblio/refs.bib new file mode 100644 --- /dev/null +++ b/tests/data/biblio/refs.bib @@ -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} +} diff --git a/tests/data/biblio/refs.yaml b/tests/data/biblio/refs.yaml new file mode 100644 --- /dev/null +++ b/tests/data/biblio/refs.yaml @@ -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 +... diff --git a/tests/data/biblio/refs2.yaml b/tests/data/biblio/refs2.yaml new file mode 100644 --- /dev/null +++ b/tests/data/biblio/refs2.yaml @@ -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 +... diff --git a/tests/data/embed.html b/tests/data/embed.html new file mode 100644 --- /dev/null +++ b/tests/data/embed.html @@ -0,0 +1,1 @@ +

$body$

diff --git a/tests/data/posts/2018-09-26.md b/tests/data/posts/2018-09-26.md new file mode 100644 --- /dev/null +++ b/tests/data/posts/2018-09-26.md @@ -0,0 +1,1 @@ +Something happened today. diff --git a/tests/data/posts/2019/05/10/tomorrow.md b/tests/data/posts/2019/05/10/tomorrow.md new file mode 100644 --- /dev/null +++ b/tests/data/posts/2019/05/10/tomorrow.md @@ -0,0 +1,1 @@ +This day hasn't happened yet (as of writing this). diff --git a/tests/data/template-empty.html b/tests/data/template-empty.html new file mode 100644 --- /dev/null +++ b/tests/data/template-empty.html diff --git a/web/site.hs b/web/site.hs new file mode 100644 --- /dev/null +++ b/web/site.hs @@ -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