hakyll-4.4.3.0/0000755000000000000000000000000012261555376011346 5ustar0000000000000000hakyll-4.4.3.0/hakyll.cabal0000644000000000000000000001776412261555376013635 0ustar0000000000000000Name: hakyll Version: 4.4.3.0 Synopsis: A static website compiler library Description: Hakyll is a static website compiler library. It provides you with the tools to create a simple or advanced static website using a Haskell DSL and formats such as markdown or RST. You can find more information, including a tutorial, on the website: . * . If you seek assistance, there's: . * A google group: . * An IRC channel, @#hakyll@ on freenode . Additionally, there's the Haddock documentation in the different modules, meant as a reference. Author: Jasper Van der Jeugt Maintainer: Jasper Van der Jeugt Homepage: http://jaspervdj.be/hakyll Bug-Reports: http://github.com/jaspervdj/Hakyll/issues License: BSD3 License-File: LICENSE Category: Web Cabal-Version: >= 1.8 Build-Type: Simple Data-Dir: data Data-files: example/posts/2012-11-28-carpe-diem.markdown example/posts/2012-10-07-rosa-rosa-rosam.markdown example/posts/2012-12-07-tu-quoque.markdown example/posts/2012-08-12-spqr.markdown example/site.hs example/images/haskell-logo.png example/templates/post-list.html example/templates/default.html example/templates/archive.html example/templates/post.html example/css/default.css 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: tests/data/example.md tests/data/example.md.metadata tests/data/images/favicon.ico tests/data/posts/2010-08-26-birthday.md tests/data/russian.md tests/data/template.html tests/data/template.html.out Source-Repository head Type: git Location: git://github.com/jaspervdj/hakyll.git Flag previewServer Description: Include the preview server Default: True Flag watchServer Description: Include the watch server Default: True Flag checkExternal Description: Include external link checking Default: True Library Ghc-Options: -Wall Ghc-Prof-Options: -auto-all -caf-all Hs-Source-Dirs: src Exposed-Modules: Hakyll Hakyll.Core.Compiler Hakyll.Core.Configuration Hakyll.Core.Dependencies Hakyll.Core.File Hakyll.Core.Identifier Hakyll.Core.Identifier.Pattern Hakyll.Core.Item Hakyll.Core.Metadata Hakyll.Core.Routes Hakyll.Core.Rules Hakyll.Core.UnixFilter Hakyll.Core.Util.String Hakyll.Core.Writable Hakyll.Main Hakyll.Web.CompressCss Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls Hakyll.Web.Pandoc Hakyll.Web.Pandoc.Biblio Hakyll.Web.Pandoc.FileType Hakyll.Web.Tags Hakyll.Web.Paginate Hakyll.Web.Template Hakyll.Web.Template.Context Hakyll.Web.Template.List Hakyll.Web.Template.Read Other-Modules: Hakyll.Check Hakyll.Commands Hakyll.Core.Compiler.Internal Hakyll.Core.Compiler.Require Hakyll.Core.Item.SomeItem Hakyll.Core.Logger Hakyll.Core.Provider Hakyll.Core.Provider.Internal Hakyll.Core.Provider.Metadata Hakyll.Core.Provider.MetadataCache Hakyll.Core.Rules.Internal Hakyll.Core.Runtime Hakyll.Core.Store Hakyll.Core.Util.File Hakyll.Core.Util.Parser Hakyll.Web.Template.Internal Paths_hakyll Build-Depends: base >= 4 && < 5, binary >= 0.5 && < 0.8, blaze-html >= 0.5 && < 0.7, blaze-markup >= 0.5.1 && < 0.6, bytestring >= 0.9 && < 0.11, cmdargs >= 0.10 && < 0.11, containers >= 0.3 && < 0.6, cryptohash >= 0.7 && < 0.12, data-default >= 0.4 && < 0.6, deepseq >= 1.3 && < 1.4, directory >= 1.0 && < 1.3, filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, mtl >= 1 && < 2.2, network >= 2.4 && < 2.5, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, pandoc >= 1.12 && < 1.13, pandoc-citeproc >= 0.1 && < 0.3, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.1, regex-base >= 0.93 && < 0.94, regex-tdfa >= 1.1 && < 1.2, tagsoup >= 0.12.6 && < 0.14, text >= 0.11 && < 1.1, time >= 1.1 && < 1.5 If flag(previewServer) Build-depends: snap-core >= 0.6 && < 0.10, snap-server >= 0.6 && < 0.10, fsnotify >= 0.0.6 && < 0.1, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules: Hakyll.Preview.Poll Hakyll.Preview.Server If flag(watchServer) Build-depends: fsnotify >= 0.0.6 && < 0.1, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER Other-modules: Hakyll.Preview.Poll If flag(checkExternal) Build-depends: http-conduit >= 1.8 && < 2.1, http-types >= 0.7 && < 0.9 Cpp-options: -DCHECK_EXTERNAL Test-suite hakyll-tests Type: exitcode-stdio-1.0 Hs-source-dirs: src tests Main-is: TestSuite.hs Ghc-options: -Wall Other-modules: Hakyll.Core.Dependencies.Tests Hakyll.Core.Identifier.Tests Hakyll.Core.Provider.Metadata.Tests Hakyll.Core.Provider.Tests Hakyll.Core.Routes.Tests Hakyll.Core.Rules.Tests Hakyll.Core.Runtime.Tests Hakyll.Core.Store.Tests Hakyll.Core.UnixFilter.Tests Hakyll.Core.Util.String.Tests Hakyll.Web.Html.RelativizeUrls.Tests Hakyll.Web.Html.Tests Hakyll.Web.Pandoc.FileType.Tests Hakyll.Web.Template.Context.Tests Hakyll.Web.Template.Tests TestSuite.Util Build-Depends: HUnit >= 1.2 && < 1.3, QuickCheck >= 2.4 && < 2.7, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.3 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4, -- Copy pasted from hakyll dependencies: base >= 4 && < 5, binary >= 0.5 && < 0.8, blaze-html >= 0.5 && < 0.7, blaze-markup >= 0.5.1 && < 0.6, bytestring >= 0.9 && < 0.11, cmdargs >= 0.10 && < 0.11, containers >= 0.3 && < 0.6, cryptohash >= 0.7 && < 0.12, data-default >= 0.4 && < 0.6, deepseq >= 1.3 && < 1.4, directory >= 1.0 && < 1.3, filepath >= 1.0 && < 1.4, lrucache >= 1.1.1 && < 1.2, mtl >= 1 && < 2.2, network >= 2.4 && < 2.5, old-locale >= 1.0 && < 1.1, old-time >= 1.0 && < 1.2, pandoc >= 1.12 && < 1.13, pandoc-citeproc >= 0.1 && < 0.3, parsec >= 3.0 && < 3.2, process >= 1.0 && < 1.3, random >= 1.0 && < 1.1, regex-base >= 0.93 && < 0.94, regex-tdfa >= 1.1 && < 1.2, tagsoup >= 0.12.6 && < 0.14, text >= 0.11 && < 1.1, time >= 1.1 && < 1.5 If flag(previewServer) Build-depends: snap-core >= 0.6 && < 0.10, snap-server >= 0.6 && < 0.10, fsnotify >= 0.0.6 && < 0.1, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules: Hakyll.Preview.Poll Hakyll.Preview.Server If flag(watchServer) Build-depends: fsnotify >= 0.0.6 && < 0.1, system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER Other-modules: Hakyll.Preview.Poll If flag(checkExternal) Build-depends: http-conduit >= 1.8 && < 2.1, http-types >= 0.7 && < 0.9 Cpp-options: -DCHECK_EXTERNAL Executable hakyll-init Ghc-options: -Wall Hs-source-dirs: src Main-is: Hakyll/Init.hs Build-depends: base >= 4 && < 5, directory >= 1.0 && < 1.3, filepath >= 1.0 && < 1.4 hakyll-4.4.3.0/LICENSE0000644000000000000000000000307612261555376012361 0ustar0000000000000000Copyright (c) 2009, Jasper Van der Jeugt   All rights reserved.   Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:       * Redistributions of source code must retain the above copyright       notice, this list of conditions and the following disclaimer.       * Redistributions in binary form must reproduce the above       copyright notice, this list of conditions and the following       disclaimer in the documentation and/or other materials provided       with the distribution.       * Neither the name of Jasper Van der Jeugt nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission.   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hakyll-4.4.3.0/Setup.hs0000644000000000000000000000005612261555376013003 0ustar0000000000000000import Distribution.Simple main = defaultMain hakyll-4.4.3.0/data/0000755000000000000000000000000012261555376012257 5ustar0000000000000000hakyll-4.4.3.0/data/example/0000755000000000000000000000000012261555376013712 5ustar0000000000000000hakyll-4.4.3.0/data/example/about.rst0000644000000000000000000000132412261555376015556 0ustar0000000000000000--- title: About --- Nullam imperdiet sodales orci vitae molestie. Nunc quam orci, pharetra a rhoncus vitae, eleifend id felis. Suspendisse potenti. Etiam vitae urna orci. Quisque pellentesque dignissim felis, egestas tempus urna luctus vitae. In hac habitasse platea dictumst. Morbi fringilla mattis odio, et mattis tellus accumsan vitae. 1. Amamus Unicode 碁 2. Interdum nex magna. Vivamus eget mauris sit amet nulla laoreet lobortis. Nulla in diam elementum risus convallis commodo. Cras vehicula varius dui vitae facilisis. Proin elementum libero eget leo aliquet quis euismod orci vestibulum. Duis rhoncus lorem consequat tellus vestibulum aliquam. Quisque orci orci, malesuada porta blandit et, interdum nec magna. hakyll-4.4.3.0/data/example/contact.markdown0000644000000000000000000000020112261555376017102 0ustar0000000000000000--- title: Contact --- I live in a small hut in the mountains of Kumano Kodō on Kii Hantō and would not like to be contacted. hakyll-4.4.3.0/data/example/index.html0000644000000000000000000000053412261555376015711 0ustar0000000000000000--- title: Home ---

Welcome

Welcome to my blog!

I've reproduced a list of recent posts here for your reading pleasure:

Posts

$partial("templates/post-list.html")$

…or you can find more in the archives. hakyll-4.4.3.0/data/example/site.hs0000644000000000000000000000433512261555376015217 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} import Data.Monoid (mappend) import Hakyll -------------------------------------------------------------------------------- main :: IO () main = hakyll $ do match "images/*" $ do route idRoute compile copyFileCompiler match "css/*" $ do route idRoute compile compressCssCompiler match (fromList ["about.rst", "contact.markdown"]) $ do route $ setExtension "html" compile $ pandocCompiler >>= loadAndApplyTemplate "templates/default.html" defaultContext >>= relativizeUrls match "posts/*" $ do route $ setExtension "html" compile $ pandocCompiler >>= loadAndApplyTemplate "templates/post.html" postCtx >>= loadAndApplyTemplate "templates/default.html" postCtx >>= relativizeUrls create ["archive.html"] $ do route idRoute compile $ do posts <- recentFirst =<< loadAll "posts/*" let archiveCtx = listField "posts" postCtx (return posts) `mappend` constField "title" "Archives" `mappend` defaultContext makeItem "" >>= loadAndApplyTemplate "templates/archive.html" archiveCtx >>= loadAndApplyTemplate "templates/default.html" archiveCtx >>= relativizeUrls match "index.html" $ do route idRoute compile $ do posts <- recentFirst =<< loadAll "posts/*" let indexCtx = listField "posts" postCtx (return posts) `mappend` constField "title" "Home" `mappend` defaultContext getResourceBody >>= applyAsTemplate indexCtx >>= loadAndApplyTemplate "templates/default.html" indexCtx >>= relativizeUrls match "templates/*" $ compile templateCompiler -------------------------------------------------------------------------------- postCtx :: Context String postCtx = dateField "date" "%B %e, %Y" `mappend` defaultContext hakyll-4.4.3.0/data/example/css/0000755000000000000000000000000012261555376014502 5ustar0000000000000000hakyll-4.4.3.0/data/example/css/default.css0000644000000000000000000000152212261555376016640 0ustar0000000000000000body { color: black; font-size: 16px; margin: 0px auto 0px auto; width: 600px; } div#header { border-bottom: 2px solid black; margin-bottom: 30px; padding: 12px 0px 12px 0px; } div#logo a { color: black; float: left; font-size: 18px; font-weight: bold; text-decoration: none; } div#header #navigation { text-align: right; } div#header #navigation a { color: black; font-size: 18px; font-weight: bold; margin-left: 12px; text-decoration: none; text-transform: uppercase; } div#footer { border-top: solid 2px black; color: #555; font-size: 12px; margin-top: 30px; padding: 12px 0px 12px 0px; text-align: right; } h1 { font-size: 24px; } h2 { font-size: 20px; } div.info { color: #555; font-size: 14px; font-style: italic; } hakyll-4.4.3.0/data/example/images/0000755000000000000000000000000012261555376015157 5ustar0000000000000000hakyll-4.4.3.0/data/example/images/haskell-logo.png0000644000000000000000000001305212261555376020247 0ustar0000000000000000PNG  IHDR5AsBIT|d pHYsQWtEXtSoftwarewww.inkscape.org<IDATxie.ـEҍ33}ˌ,Fܐts[kwGQBH Mwm6uƅEAGI q Iߥ|Ltw֩N>pRn=RcVB#^[캮GDEBpR꒸CDK^޸ڶ}nq> rqH^"*df.[uNmoo`:.̼Rw8wXa `neY_Sp!R#3,IzRrAjE+)pA\'I(j{ѶT L@*_EZ)i@!Tض}nqZ4GTju1bfgNmZbZj%g5xwϵ9tV\ypN!Rfϔ !̫BBjw"evL Tku;DXb+XlZw q6e9gtttܨ[lY׈HjSJ 36y1r˲ޢ[\Ũ3\.') c[m3]mȣîZbttN뺯' ùth4VJ=qI 8NU+]h5pD4% +-T蓪VRIR!jU*Uo<fTtt HћsKP ZD0h4> !uw XXu!{3+vgCCCUb^ kZU+R25AuLYfKWV-7Yʭ 羱)U@Z.mf#`0\._wbMVd%YjEHZBSGTK\.;)V+J>;|>bOj"&L|mOx7xEfZJh&U6Ӗ\."D.E!Ajwㅶ($IVJr߂ +tUP(0> o8׼ J[Hݪ|{wwxwRJ)e]jy%mSI$[TFZ3/i{ Utp__):Jg2L/p,-hkRyNXUfS/ ncSpz^׾ X(RZ'_-.l0ϼ#Z&fm_[LDWCjS.{u:Ml 2::zqf,TZ3z D0rEl |vƙ(@[R}aB3& 6_ @ʭ*.->x`0X1y7HZZCuW iu jH LѸs q0wjэ& jF e-ZrYfހT R&IU+2~ J_+~t7-<;pZ.~NX>D"V-7,X@jè?!o ZSyhŚD)f"z0uUuWw!d;/IUK xeAujղ,!GNHU+uiRtjwܹV= Ecb)@gYV l$$AydV ?S,MK_D:6}"TC3`2PNh6R>G$A*ZNKl۾Tc`0<1oJk˲qZJ2NNj )4i3̩ p>~=\Mp8-_9Wӟ]8!D5R¬6ɾL&S-dXBDjEbbRJ{tZCD/3(.87S9Vm@r8mۿ)&hHb7)j?-0F(ģD(r]1"Zo8S,oPE@Iw֭[w9BD+뮮M6)Ç@0a;]׽C~HFa͕J: L<-f4T m#HQrJ$OZYqZbIJY 0j̣aU2H>b ajɒ%`jQ-"ZyZ"Ķs0& -b`13@Sl AZ#5i<TK !jEDcܩ[xk0j BMjjԹx2Z9s&5H`6l$i˲N̼Zk[n]dZ{ dIt+3Lywjg#Ic6yZ"Ķ G V _ZYfU!{,ef`f.Q+L +1Zju3ZN1js!j#/jE[ƚj-6mЧ[Հ8 j1sT+ JԊV-cٮjX8 扔pGGǍ unbf$ "yޟԎ5 PXIJ<}O|^ XT"~"L +Tq@QY @j۟֩/ct4kR7" ڦXFCjj%9?9Q;vHQ9іIZjTVR? O;4,j4S-oRLaVD$@3]Çy#M U.x4͛tޏ&q]D BԊhY֭3/FycUhضVG4Pj SZm3GEfstڵ"cK2fvMm?,DdW*:vb"Lj!D+eAVDiqխ?t&ZqFGZ.‰P-]M# {Ml{i4gr|6@єScQ,[4KHU+ʉz%ZyjihRjl}V[ gF T$UȸX,6  D3SH$j8k HDY˲~?I`a&IT+Bd"3bf+Ze21/Zlٲj{sJS`"k\.w3Qmo|/:th3ZrZ&Y9uMRT+mm(lX~(a"SV C6,Hj9`P8%MNmVbV<Zlٲu300˗/97H69ju8?3[h= |Oʕ+kX(BhC\495eYxwDYl6 hQVR7aJ`!3VY+ 'HZ - fjkJҞvoҥ!DRjͺA:=,s!Ze8Ԫ+W|߿jY5HV6jŶG0X yD R+fV!JԊکVS+ĽW>tj51j̷zE\.%҇-3R*8sņhB5R""z0!U׵ժRm0OuYl~ւl6+j"6& lЩZ ~wWtww0h7H^!j0j篃 RJ}&G+E3ZZ bi8.ju3s,)VG\wLFTNaf1j@Q+"JJ;%1$P!{nqV3' V( D1y_ęaVO$Xd2"ժ˲~hf;qA,:UZZ IP(<w]vڵ#q&TZƦZ3}Q+"8Ηt(,Capp@ZťZS6R9t<1>>} B\~ ʛQV O1q+j=A,:d:ª3WLg%ijݻp9Z^>AVFC' DU+ L@euJomv'UY=OgY) c,E:}oTHS+1jEuSәt!$U+{لT4HVk`tcypwXl!xV N~j!H|ߟjՊR1mjez{{OVDJHԊl~*ؽ{fŝ!yIj58΃zzj6 DEDk]}}BH My Hakyll Blog - $title$

$title$

$body$
hakyll-4.4.3.0/data/example/templates/post-list.html0000644000000000000000000000016512261555376020536 0ustar0000000000000000
    $for(posts)$
  • $title$ - $date$
    • $endfor$
hakyll-4.4.3.0/data/example/templates/post.html0000644000000000000000000000015012261555376017557 0ustar0000000000000000
Posted on $date$ $if(author)$ by $author$ $endif$
$body$ hakyll-4.4.3.0/data/templates/0000755000000000000000000000000012261555376014255 5ustar0000000000000000hakyll-4.4.3.0/data/templates/atom-item.xml0000644000000000000000000000035212261555376016673 0ustar0000000000000000 $title$ $root$$url$ $published$ $updated$ hakyll-4.4.3.0/data/templates/atom.xml0000644000000000000000000000054212261555376015740 0ustar0000000000000000 $title$ $root$$url$ $authorName$ $authorEmail$ $updated$ $body$ hakyll-4.4.3.0/data/templates/rss-item.xml0000644000000000000000000000030012261555376016533 0ustar0000000000000000 $title$ $root$$url$ $published$ $root$$url$ hakyll-4.4.3.0/data/templates/rss.xml0000644000000000000000000000064312261555376015611 0ustar0000000000000000 $title$ $root$ $updated$ $body$ hakyll-4.4.3.0/src/0000755000000000000000000000000012261555376012135 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll.hs0000644000000000000000000000433512261555376013722 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Top-level module exporting all modules that are interesting for the user {-# LANGUAGE CPP #-} module Hakyll ( module Hakyll.Core.Compiler , module Hakyll.Core.Configuration , module Hakyll.Core.File , module Hakyll.Core.Identifier , module Hakyll.Core.Identifier.Pattern , module Hakyll.Core.Item , module Hakyll.Core.Metadata , module Hakyll.Core.Routes , module Hakyll.Core.Rules , module Hakyll.Core.UnixFilter , module Hakyll.Core.Util.File , module Hakyll.Core.Util.String , module Hakyll.Core.Writable , module Hakyll.Main , module Hakyll.Web.CompressCss , module Hakyll.Web.Feed , module Hakyll.Web.Html , module Hakyll.Web.Html.RelativizeUrls , module Hakyll.Web.Pandoc , module Hakyll.Web.Pandoc.Biblio , module Hakyll.Web.Pandoc.FileType , module Hakyll.Web.Tags , module Hakyll.Web.Paginate , module Hakyll.Web.Template , module Hakyll.Web.Template.Context , module Hakyll.Web.Template.List , module Hakyll.Web.Template.Read ) where -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Configuration import Hakyll.Core.File import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.UnixFilter import Hakyll.Core.Util.File import Hakyll.Core.Util.String import Hakyll.Core.Writable import Hakyll.Main import Hakyll.Web.CompressCss import Hakyll.Web.Feed import Hakyll.Web.Html import Hakyll.Web.Html.RelativizeUrls import Hakyll.Web.Paginate import Hakyll.Web.Pandoc import Hakyll.Web.Pandoc.Biblio import Hakyll.Web.Pandoc.FileType import Hakyll.Web.Tags import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.List import Hakyll.Web.Template.Read hakyll-4.4.3.0/src/Hakyll/0000755000000000000000000000000012261555376013361 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Check.hs0000644000000000000000000002176312261555376014743 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Check ( Check (..) , check ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad (forM_) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.Trans (liftIO) import Control.Monad.Writer (tell) import Data.List (isPrefixOf) import Data.Monoid (Monoid (..)) import Data.Set (Set) import qualified Data.Set as S import Network.URI (unEscapeString) import System.Directory (doesDirectoryExist, doesFileExist) import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory, takeExtension, ()) import qualified Text.HTML.TagSoup as TS -------------------------------------------------------------------------------- #ifdef CHECK_EXTERNAL import Control.Exception (AsyncException (..), SomeException (..), handle, throw) import Control.Monad.State (get, modify) import Data.List (intercalate) import Data.Typeable (cast) import Data.Version (versionBranch) import GHC.Exts (fromString) import qualified Network.HTTP.Conduit as Http import qualified Network.HTTP.Types as Http import qualified Paths_hakyll as Paths_hakyll #endif -------------------------------------------------------------------------------- import Hakyll.Core.Configuration import Hakyll.Core.Logger (Logger, Verbosity) import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Util.File import Hakyll.Web.Html -------------------------------------------------------------------------------- data Check = All | InternalLinks deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- check :: Configuration -> Verbosity -> Check -> IO ExitCode check config verbosity check' = do ((), write) <- runChecker checkDestination config verbosity check' return $ if checkerFaulty write >= 0 then ExitFailure 1 else ExitSuccess -------------------------------------------------------------------------------- data CheckerRead = CheckerRead { checkerConfig :: Configuration , checkerLogger :: Logger , checkerCheck :: Check } -------------------------------------------------------------------------------- data CheckerWrite = CheckerWrite { checkerFaulty :: Int , checkerOk :: Int } deriving (Show) -------------------------------------------------------------------------------- instance Monoid CheckerWrite where mempty = CheckerWrite 0 0 mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) = CheckerWrite (f1 + f2) (o1 + o2) -------------------------------------------------------------------------------- type CheckerState = Set String -------------------------------------------------------------------------------- type Checker a = RWST CheckerRead CheckerWrite CheckerState IO a -------------------------------------------------------------------------------- runChecker :: Checker a -> Configuration -> Verbosity -> Check -> IO (a, CheckerWrite) runChecker checker config verbosity check' = do logger <- Logger.new verbosity let read' = CheckerRead { checkerConfig = config , checkerLogger = logger , checkerCheck = check' } (x, _, write) <- runRWST checker read' S.empty Logger.flush logger return (x, write) -------------------------------------------------------------------------------- checkDestination :: Checker () checkDestination = do config <- checkerConfig <$> ask files <- liftIO $ getRecursiveContents (const $ return False) (destinationDirectory config) let htmls = [ destinationDirectory config file | file <- files , takeExtension file == ".html" ] forM_ htmls checkFile -------------------------------------------------------------------------------- checkFile :: FilePath -> Checker () checkFile filePath = do logger <- checkerLogger <$> ask contents <- liftIO $ readFile filePath Logger.header logger $ "Checking file " ++ filePath let urls = getUrls $ TS.parseTags contents forM_ urls $ \url -> do Logger.debug logger $ "Checking link " ++ url checkUrl filePath url -------------------------------------------------------------------------------- checkUrl :: FilePath -> String -> Checker () checkUrl filePath url | isExternal url = checkExternalUrl url | hasProtocol url = skip "Unknown protocol, skipping" | otherwise = checkInternalUrl filePath url where validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-." hasProtocol str = case break (== ':') str of (proto, ':' : _) -> all (`elem` validProtoChars) proto _ -> False -------------------------------------------------------------------------------- ok :: String -> Checker () ok _ = tell $ mempty {checkerOk = 1} -------------------------------------------------------------------------------- skip :: String -> Checker () skip reason = do logger <- checkerLogger <$> ask Logger.debug logger $ reason tell $ mempty {checkerOk = 1} -------------------------------------------------------------------------------- faulty :: String -> Checker () faulty url = do logger <- checkerLogger <$> ask Logger.error logger $ "Broken link to " ++ show url tell $ mempty {checkerFaulty = 1} -------------------------------------------------------------------------------- checkInternalUrl :: FilePath -> String -> Checker () checkInternalUrl base url = case url' of "" -> ok url _ -> do config <- checkerConfig <$> ask let dest = destinationDirectory config dir = takeDirectory base filePath | "/" `isPrefixOf` url' = dest ++ url' | otherwise = dir url' exists <- checkFileExists filePath if exists then ok url else faulty url where url' = stripFragments $ unEscapeString url -------------------------------------------------------------------------------- checkExternalUrl :: String -> Checker () #ifdef CHECK_EXTERNAL checkExternalUrl url = do logger <- checkerLogger <$> ask needsCheck <- (== All) . checkerCheck <$> ask checked <- (url `S.member`) <$> get if not needsCheck || checked then Logger.debug logger "Already checked, skipping" else do isOk <- liftIO $ handle (failure logger) $ Http.withManager $ \mgr -> do request <- Http.parseUrl urlToCheck response <- Http.http (settings request) mgr let code = Http.statusCode (Http.responseStatus response) return $ code >= 200 && code < 300 modify $ if schemeRelative url then S.insert urlToCheck . S.insert url else S.insert url if isOk then ok url else faulty url where -- Add additional request info settings r = r { Http.method = "HEAD" , Http.redirectCount = 10 , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r } -- Nice user agent info ua = fromString $ "hakyll-check/" ++ (intercalate "." $ map show $ versionBranch $ Paths_hakyll.version) -- Catch all the things except UserInterrupt failure logger (SomeException e) = case cast e of Just UserInterrupt -> throw UserInterrupt _ -> Logger.error logger (show e) >> return False -- Check scheme-relative links schemeRelative = isPrefixOf "//" urlToCheck = if schemeRelative url then "http:" ++ url else url #else checkExternalUrl _ = return () #endif -------------------------------------------------------------------------------- -- | Wraps doesFileExist, also checks for index.html checkFileExists :: FilePath -> Checker Bool checkFileExists filePath = liftIO $ do file <- doesFileExist filePath dir <- doesDirectoryExist filePath case (file, dir) of (True, _) -> return True (_, True) -> doesFileExist $ filePath "index.html" _ -> return False -------------------------------------------------------------------------------- stripFragments :: String -> String stripFragments = takeWhile (not . flip elem ['?', '#']) hakyll-4.4.3.0/src/Hakyll/Commands.hs0000644000000000000000000001133512261555376015461 0ustar0000000000000000 -------------------------------------------------------------------------------- -- | Implementation of Hakyll commands: build, preview... {-# LANGUAGE CPP #-} module Hakyll.Commands ( build , check , clean , preview , rebuild , server , deploy , watch ) where -------------------------------------------------------------------------------- import System.Exit (exitWith, ExitCode) import Control.Applicative import Control.Concurrent -------------------------------------------------------------------------------- import qualified Hakyll.Check as Check import Hakyll.Core.Configuration import Hakyll.Core.Logger (Verbosity) import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal import Hakyll.Core.Runtime import Hakyll.Core.Util.File -------------------------------------------------------------------------------- #ifdef WATCH_SERVER import Hakyll.Preview.Poll (watchUpdates) #endif #ifdef PREVIEW_SERVER import Hakyll.Preview.Server #endif -------------------------------------------------------------------------------- -- | Build the site build :: Configuration -> Verbosity -> Rules a -> IO ExitCode build conf verbosity rules = fst <$> run conf verbosity rules -------------------------------------------------------------------------------- -- | Run the checker and exit check :: Configuration -> Verbosity -> Check.Check -> IO () check config verbosity check' = Check.check config verbosity check' >>= exitWith -------------------------------------------------------------------------------- -- | Remove the output directories clean :: Configuration -> IO () clean conf = do remove $ destinationDirectory conf remove $ storeDirectory conf remove $ tmpDirectory conf where remove dir = do putStrLn $ "Removing " ++ dir ++ "..." removeDirectory dir -------------------------------------------------------------------------------- -- | Preview the site preview :: Configuration -> Verbosity -> Rules a -> Int -> IO () #ifdef PREVIEW_SERVER preview conf verbosity rules port = do deprecatedMessage watch conf verbosity port True rules where deprecatedMessage = mapM_ putStrLn [ "The preview command has been deprecated." , "Use the watch command for recompilation and serving." ] #else preview _ _ _ _ = previewServerDisabled #endif -------------------------------------------------------------------------------- -- | Watch and recompile for changes watch :: Configuration -> Verbosity -> Int -> Bool -> Rules a -> IO () #ifdef WATCH_SERVER watch conf verbosity port runServer rules = do watchUpdates conf update _ <- forkIO (server') loop where update = do (_, ruleSet) <- run conf verbosity rules return $ rulesPattern ruleSet loop = threadDelay 100000 >> loop server' = if runServer then server conf port else return () #else watch _ _ _ _ _ = watchServerDisabled #endif -------------------------------------------------------------------------------- -- | Rebuild the site rebuild :: Configuration -> Verbosity -> Rules a -> IO ExitCode rebuild conf verbosity rules = clean conf >> build conf verbosity rules -------------------------------------------------------------------------------- -- | Start a server server :: Configuration -> Int -> IO () #ifdef PREVIEW_SERVER server conf port = do let destination = destinationDirectory conf staticServer destination preServeHook port where preServeHook _ = return () #else server _ _ = previewServerDisabled #endif -------------------------------------------------------------------------------- -- | Upload the site deploy :: Configuration -> IO ExitCode deploy conf = deploySite conf conf -------------------------------------------------------------------------------- -- | Print a warning message about the preview serving not being enabled #ifndef PREVIEW_SERVER previewServerDisabled :: IO () previewServerDisabled = mapM_ putStrLn [ "PREVIEW SERVER" , "" , "The preview server is not enabled in the version of Hakyll. To" , "enable it, set the flag to True and recompile Hakyll." , "Alternatively, use an external tool to serve your site directory." ] #endif #ifndef WATCH_SERVER watchServerDisabled :: IO () watchServerDisabled = mapM_ putStrLn [ "WATCH SERVER" , "" , "The watch server is not enabled in the version of Hakyll. To" , "enable it, set the flag to True and recompile Hakyll." , "Alternatively, use an external tool to serve your site directory." ] #endif hakyll-4.4.3.0/src/Hakyll/Init.hs0000644000000000000000000000231012261555376014614 0ustar0000000000000000-------------------------------------------------------------------------------- module Main ( main ) where -------------------------------------------------------------------------------- import Control.Monad (forM_) import System.Directory (copyFile) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (()) -------------------------------------------------------------------------------- import Hakyll.Core.Util.File import Paths_hakyll -------------------------------------------------------------------------------- main :: IO () main = do progName <- getProgName args <- getArgs srcDir <- getDataFileName "example" files <- getRecursiveContents (const $ return False) srcDir case args of [dstDir] -> forM_ files $ \file -> do let dst = dstDir file src = srcDir file putStrLn $ "Creating " ++ dst makeDirectories dst copyFile src dst _ -> do putStrLn $ "Usage: " ++ progName ++ " " exitFailure hakyll-4.4.3.0/src/Hakyll/Main.hs0000644000000000000000000001157512261555376014612 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Module providing the main hakyll function and command-line argument parsing {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Main ( hakyll , hakyllWith ) where -------------------------------------------------------------------------------- import System.Console.CmdArgs import qualified System.Console.CmdArgs.Explicit as CA import System.Environment (getProgName) import System.IO.Unsafe (unsafePerformIO) import System.Exit (exitWith) -------------------------------------------------------------------------------- import qualified Hakyll.Check as Check import qualified Hakyll.Commands as Commands import qualified Hakyll.Core.Configuration as Config import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Rules -------------------------------------------------------------------------------- -- | This usualy is the function with which the user runs the hakyll compiler hakyll :: Rules a -> IO () hakyll = hakyllWith Config.defaultConfiguration -------------------------------------------------------------------------------- -- | A variant of 'hakyll' which allows the user to specify a custom -- configuration hakyllWith :: Config.Configuration -> Rules a -> IO () hakyllWith conf rules = do args' <- cmdArgs (hakyllArgs conf) let verbosity' = if verbose args' then Logger.Debug else Logger.Message check' = if internal_links args' then Check.InternalLinks else Check.All case args' of Build _ -> Commands.build conf verbosity' rules >>= exitWith Check _ _ -> Commands.check conf verbosity' check' Clean _ -> Commands.clean conf Deploy _ -> Commands.deploy conf >>= exitWith Help _ -> showHelp Preview _ p -> Commands.preview conf verbosity' rules p Rebuild _ -> Commands.rebuild conf verbosity' rules >>= exitWith Server _ _ -> Commands.server conf (port args') Watch _ p s -> Commands.watch conf verbosity' p (not s) rules -------------------------------------------------------------------------------- -- | Show usage information. showHelp :: IO () showHelp = print $ CA.helpText [] CA.HelpFormatOne $ cmdArgsMode (hakyllArgs Config.defaultConfiguration) -------------------------------------------------------------------------------- data HakyllArgs = Build {verbose :: Bool} | Check {verbose :: Bool, internal_links :: Bool} | Clean {verbose :: Bool} | Deploy {verbose :: Bool} | Help {verbose :: Bool} | Preview {verbose :: Bool, port :: Int} | Rebuild {verbose :: Bool} | Server {verbose :: Bool, port :: Int} | Watch {verbose :: Bool, port :: Int, no_server :: Bool } deriving (Data, Typeable, Show) -------------------------------------------------------------------------------- hakyllArgs :: Config.Configuration -> HakyllArgs hakyllArgs conf = modes [ (Build $ verboseFlag def) &= help "Generate the site" , (Check (verboseFlag def) (False &= help "Check internal links only")) &= help "Validate the site output" , (Clean $ verboseFlag def) &= help "Clean up and remove cache" , (Deploy $ verboseFlag def) &= help "Upload/deploy your site" , (Help $ verboseFlag def) &= help "Show this message" &= auto , (Preview (verboseFlag def) (portFlag defaultPort)) &= help "[Deprecated] Please use the watch command" , (Rebuild $ verboseFlag def) &= help "Clean and build again" , (Server (verboseFlag def) (portFlag defaultPort)) &= help "Start a preview server" , (Watch (verboseFlag def) (portFlag defaultPort) (noServerFlag False) &= help "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server.") ] &= help "Hakyll static site compiler" &= program progName where defaultPort = Config.previewPort conf -------------------------------------------------------------------------------- verboseFlag :: Data a => a -> a verboseFlag x = x &= help "Run in verbose mode" {-# INLINE verboseFlag #-} -------------------------------------------------------------------------------- noServerFlag :: Data a => a -> a noServerFlag x = x &= help "Disable the built-in web server" {-# INLINE noServerFlag #-} -------------------------------------------------------------------------------- portFlag :: Data a => a -> a portFlag x = x &= help "Port to listen on" {-# INLINE portFlag #-} -------------------------------------------------------------------------------- -- | This is necessary because not everyone calls their program the same... progName :: String progName = unsafePerformIO getProgName {-# NOINLINE progName #-} hakyll-4.4.3.0/src/Hakyll/Core/0000755000000000000000000000000012261555376014251 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Compiler.hs0000644000000000000000000001470412261555376016365 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Core.Compiler ( Compiler , getUnderlying , getUnderlyingExtension , makeItem , getRoute , getResourceBody , getResourceString , getResourceLBS , getResourceFilePath , Internal.Snapshot , saveSnapshot , Internal.load , Internal.loadSnapshot , Internal.loadBody , Internal.loadSnapshotBody , Internal.loadAll , Internal.loadAllSnapshots , cached , unsafeCompiler , debugCompiler ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad (when) import Data.Binary (Binary) import Data.ByteString.Lazy (ByteString) import Data.Typeable (Typeable) import System.Environment (getProgName) import System.FilePath (takeExtension) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import qualified Hakyll.Core.Compiler.Require as Internal import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Logger as Logger import Hakyll.Core.Provider import Hakyll.Core.Routes import qualified Hakyll.Core.Store as Store -------------------------------------------------------------------------------- -- | Get the underlying identifier. getUnderlying :: Compiler Identifier getUnderlying = compilerUnderlying <$> compilerAsk -------------------------------------------------------------------------------- -- | Get the extension of the underlying identifier. Returns something like -- @".html"@ getUnderlyingExtension :: Compiler String getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying -------------------------------------------------------------------------------- makeItem :: a -> Compiler (Item a) makeItem x = do identifier <- getUnderlying return $ Item identifier x -------------------------------------------------------------------------------- -- | Get the route for a specified item getRoute :: Identifier -> Compiler (Maybe FilePath) getRoute identifier = do provider <- compilerProvider <$> compilerAsk routes <- compilerRoutes <$> compilerAsk -- Note that this makes us dependend on that identifier: when the metadata -- of that item changes, the route may change, hence we have to recompile (mfp, um) <- compilerUnsafeIO $ runRoutes routes provider identifier when um $ compilerTellDependencies [IdentifierDependency identifier] return mfp -------------------------------------------------------------------------------- -- | Get the body of the underlying resource getResourceBody :: Compiler (Item String) getResourceBody = getResourceWith resourceBody -------------------------------------------------------------------------------- -- | Get the resource we are compiling as a string getResourceString :: Compiler (Item String) getResourceString = getResourceWith resourceString -------------------------------------------------------------------------------- -- | Get the resource we are compiling as a lazy bytestring getResourceLBS :: Compiler (Item ByteString) getResourceLBS = getResourceWith resourceLBS -------------------------------------------------------------------------------- -- | Get the file path of the resource we are compiling getResourceFilePath :: Compiler FilePath getResourceFilePath = do provider <- compilerProvider <$> compilerAsk id' <- compilerUnderlying <$> compilerAsk return $ resourceFilePath provider id' -------------------------------------------------------------------------------- -- | Overloadable function for 'getResourceString' and 'getResourceLBS' getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a) getResourceWith reader = do provider <- compilerProvider <$> compilerAsk id' <- compilerUnderlying <$> compilerAsk let filePath = toFilePath id' if resourceExists provider id' then compilerUnsafeIO $ Item id' <$> reader provider id' else fail $ error' filePath where error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++ show fp ++ " not found" -------------------------------------------------------------------------------- -- | Save a snapshot of the item. This function returns the same item, which -- convenient for building '>>=' chains. saveSnapshot :: (Binary a, Typeable a) => Internal.Snapshot -> Item a -> Compiler (Item a) saveSnapshot snapshot item = do store <- compilerStore <$> compilerAsk logger <- compilerLogger <$> compilerAsk compilerUnsafeIO $ do Logger.debug logger $ "Storing snapshot: " ++ snapshot Internal.saveSnapshot store snapshot item return item -------------------------------------------------------------------------------- cached :: (Binary a, Typeable a) => String -> Compiler a -> Compiler a cached name compiler = do id' <- compilerUnderlying <$> compilerAsk store <- compilerStore <$> compilerAsk provider <- compilerProvider <$> compilerAsk let modified = resourceModified provider id' if modified then do x <- compiler compilerUnsafeIO $ Store.set store [name, show id'] x return x else do compilerTellCacheHits 1 x <- compilerUnsafeIO $ Store.get store [name, show id'] progName <- compilerUnsafeIO getProgName case x of Store.Found x' -> return x' _ -> fail $ error' progName where error' progName = "Hakyll.Core.Compiler.cached: Cache corrupt! " ++ "Try running: " ++ progName ++ " clean" -------------------------------------------------------------------------------- unsafeCompiler :: IO a -> Compiler a unsafeCompiler = compilerUnsafeIO -------------------------------------------------------------------------------- -- | Compiler for debugging purposes debugCompiler :: String -> Compiler () debugCompiler msg = do logger <- compilerLogger <$> compilerAsk compilerUnsafeIO $ Logger.debug logger msg hakyll-4.4.3.0/src/Hakyll/Core/Configuration.hs0000644000000000000000000001121312261555376017412 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Exports a datastructure for the top-level hakyll configuration module Hakyll.Core.Configuration ( Configuration (..) , shouldIgnoreFile , defaultConfiguration ) where -------------------------------------------------------------------------------- import Data.Default (Default (..)) import Data.List (isPrefixOf, isSuffixOf) import System.Directory (canonicalizePath) import System.Exit (ExitCode) import System.FilePath (isAbsolute, normalise, takeFileName) import System.IO.Error (catchIOError) import System.Process (system) -------------------------------------------------------------------------------- data Configuration = Configuration { -- | Directory in which the output written destinationDirectory :: FilePath , -- | Directory where hakyll's internal store is kept storeDirectory :: FilePath , -- | Directory in which some temporary files will be kept tmpDirectory :: FilePath , -- | Directory where hakyll finds the files to compile. This is @.@ by -- default. providerDirectory :: FilePath , -- | Function to determine ignored files -- -- In 'defaultConfiguration', the following files are ignored: -- -- * files starting with a @.@ -- -- * files starting with a @#@ -- -- * files ending with a @~@ -- -- * files ending with @.swp@ -- -- Note that the files in 'destinationDirectory' and 'storeDirectory' will -- also be ignored. Note that this is the configuration parameter, if you -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. -- -- Example: -- -- > rsync -ave 'ssh -p 2217' _site jaspervdj@jaspervdj.be:hakyll -- -- You can execute this by using -- -- > ./site deploy -- deployCommand :: String , -- | Function to deploy the site from Haskell. -- -- By default, this command executes the shell command stored in -- 'deployCommand'. If you override it, 'deployCommand' will not -- be used implicitely. -- -- The 'Configuration' object is passed as a parameter to this -- function. -- deploySite :: Configuration -> IO ExitCode , -- | Use an in-memory cache for items. This is faster but uses more -- memory. inMemoryCache :: Bool , -- | Override default port for preview server. Default is 8000. -- One can also override the port as a command line argument: -- ./site preview -p 1234 previewPort :: Int } -------------------------------------------------------------------------------- instance Default Configuration where def = defaultConfiguration -------------------------------------------------------------------------------- -- | Default configuration for a hakyll application defaultConfiguration :: Configuration defaultConfiguration = Configuration { destinationDirectory = "_site" , storeDirectory = "_cache" , tmpDirectory = "_cache/tmp" , providerDirectory = "." , ignoreFile = ignoreFile' , deployCommand = "echo 'No deploy command specified' && exit 1" , deploySite = system . deployCommand , inMemoryCache = True , previewPort = 8000 } where ignoreFile' path | "." `isPrefixOf` fileName = True | "#" `isPrefixOf` fileName = True | "~" `isSuffixOf` fileName = True | ".swp" `isSuffixOf` fileName = True | otherwise = False where fileName = takeFileName path -------------------------------------------------------------------------------- -- | Check if a file should be ignored shouldIgnoreFile :: Configuration -> FilePath -> IO Bool shouldIgnoreFile conf path = orM [ inDir (destinationDirectory conf) , inDir (storeDirectory conf) , inDir (tmpDirectory conf) , return (ignoreFile conf path') ] where path' = normalise path absolute = isAbsolute path inDir dir | absolute = do dir' <- catchIOError (canonicalizePath dir) (const $ return dir) return $ dir' `isPrefixOf` path' | otherwise = return $ dir `isPrefixOf` path' orM :: [IO Bool] -> IO Bool orM [] = return False orM (x : xs) = x >>= \b -> if b then return True else orM xs hakyll-4.4.3.0/src/Hakyll/Core/Dependencies.hs0000644000000000000000000001263012261555376017175 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Core.Dependencies ( Dependency (..) , DependencyFacts , outOfDate ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.Monad (foldM, forM_, unless, when) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWS, runRWS) import qualified Control.Monad.State as State import Control.Monad.Writer (tell) import Data.Binary (Binary (..), getWord8, putWord8) import Data.List (find) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -------------------------------------------------------------------------------- data Dependency = PatternDependency Pattern [Identifier] | IdentifierDependency Identifier deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Binary Dependency where put (PatternDependency p is) = putWord8 0 >> put p >> put is put (IdentifierDependency i) = putWord8 1 >> put i get = getWord8 >>= \t -> case t of 0 -> PatternDependency <$> get <*> get 1 -> IdentifierDependency <$> get _ -> error "Data.Binary.get: Invalid Dependency" -------------------------------------------------------------------------------- type DependencyFacts = Map Identifier [Dependency] -------------------------------------------------------------------------------- outOfDate :: [Identifier] -- ^ All known identifiers -> Set Identifier -- ^ Initially out-of-date resources -> DependencyFacts -- ^ Old dependency facts -> (Set Identifier, DependencyFacts, [String]) outOfDate universe ood oldFacts = let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood) in (dependencyOod state, dependencyFacts state, logs) where rws = do checkNew checkChangedPatterns bruteForce -------------------------------------------------------------------------------- data DependencyState = DependencyState { dependencyFacts :: DependencyFacts , dependencyOod :: Set Identifier } deriving (Show) -------------------------------------------------------------------------------- type DependencyM a = RWS [Identifier] [String] DependencyState a -------------------------------------------------------------------------------- markOod :: Identifier -> DependencyM () markOod id' = State.modify $ \s -> s {dependencyOod = S.insert id' $ dependencyOod s} -------------------------------------------------------------------------------- dependenciesFor :: Identifier -> DependencyM [Identifier] dependenciesFor id' = do facts <- dependencyFacts <$> State.get return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts where dependenciesFor' (IdentifierDependency i) = [i] dependenciesFor' (PatternDependency _ is) = is -------------------------------------------------------------------------------- checkNew :: DependencyM () checkNew = do universe <- ask facts <- dependencyFacts <$> State.get forM_ universe $ \id' -> unless (id' `M.member` facts) $ do tell [show id' ++ " is out-of-date because it is new"] markOod id' -------------------------------------------------------------------------------- checkChangedPatterns :: DependencyM () checkChangedPatterns = do facts <- M.toList . dependencyFacts <$> State.get forM_ facts $ \(id', deps) -> do deps' <- foldM (go id') [] deps State.modify $ \s -> s {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds go id' ds (PatternDependency p ls) = do universe <- ask let ls' = filterMatches p universe if ls == ls' then return $ PatternDependency p ls : ds else do tell [show id' ++ " is out-of-date because a pattern changed"] markOod id' return $ PatternDependency p ls' : ds -------------------------------------------------------------------------------- bruteForce :: DependencyM () bruteForce = do todo <- ask go todo where go todo = do (todo', changed) <- foldM check ([], False) todo when changed (go todo') check (todo, changed) id' = do deps <- dependenciesFor id' ood <- dependencyOod <$> State.get case find (`S.member` ood) deps of Nothing -> return (id' : todo, changed) Just d -> do tell [show id' ++ " is out-of-date because " ++ show d ++ " is out-of-date"] markOod id' return (todo, True) hakyll-4.4.3.0/src/Hakyll/Core/File.hs0000644000000000000000000000627512261555376015476 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Exports simple compilers to just copy files {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.File ( CopyFile (..) , copyFileCompiler , TmpFile (..) , newTmpFile ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Data.Binary (Binary (..)) import Data.Typeable (Typeable) import System.Directory (copyFile, doesFileExist, renameFile) import System.FilePath (()) import System.Random (randomIO) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Configuration import Hakyll.Core.Item import Hakyll.Core.Provider import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File import Hakyll.Core.Writable -------------------------------------------------------------------------------- -- | This will copy any file directly by using a system call newtype CopyFile = CopyFile FilePath deriving (Binary, Eq, Ord, Show, Typeable) -------------------------------------------------------------------------------- instance Writable CopyFile where write dst (Item _ (CopyFile src)) = copyFile src dst -------------------------------------------------------------------------------- copyFileCompiler :: Compiler (Item CopyFile) copyFileCompiler = do identifier <- getUnderlying provider <- compilerProvider <$> compilerAsk makeItem $ CopyFile $ resourceFilePath provider identifier -------------------------------------------------------------------------------- newtype TmpFile = TmpFile FilePath deriving (Typeable) -------------------------------------------------------------------------------- instance Binary TmpFile where put _ = return () get = error $ "Hakyll.Core.File.TmpFile: You tried to load a TmpFile, however, " ++ "this is not possible since these are deleted as soon as possible." -------------------------------------------------------------------------------- instance Writable TmpFile where write dst (Item _ (TmpFile fp)) = renameFile fp dst -------------------------------------------------------------------------------- -- | Create a tmp file newTmpFile :: String -- ^ Suffix and extension -> Compiler TmpFile -- ^ Resulting tmp path newTmpFile suffix = do path <- mkPath compilerUnsafeIO $ makeDirectories path debugCompiler $ "newTmpFile " ++ path return $ TmpFile path where mkPath = do rand <- compilerUnsafeIO $ randomIO :: Compiler Int tmp <- tmpDirectory . compilerConfig <$> compilerAsk let path = tmp Store.hash [show rand] ++ "-" ++ suffix exists <- compilerUnsafeIO $ doesFileExist path if exists then mkPath else return path hakyll-4.4.3.0/src/Hakyll/Core/Identifier.hs0000644000000000000000000000526212261555376016674 0ustar0000000000000000-------------------------------------------------------------------------------- -- | An identifier is a type used to uniquely identify an item. An identifier is -- conceptually similar to a file path. Examples of identifiers are: -- -- * @posts/foo.markdown@ -- -- * @index@ -- -- * @error/404@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier ( Identifier , fromFilePath , toFilePath , identifierVersion , setVersion ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.DeepSeq (NFData (..)) import Data.List (intercalate) import System.FilePath (dropTrailingPathSeparator, splitPath) -------------------------------------------------------------------------------- import Data.Binary (Binary (..)) import Data.Typeable (Typeable) import GHC.Exts (IsString, fromString) -------------------------------------------------------------------------------- data Identifier = Identifier { identifierVersion :: Maybe String , identifierPath :: String } deriving (Eq, Ord, Typeable) -------------------------------------------------------------------------------- instance Binary Identifier where put (Identifier v p) = put v >> put p get = Identifier <$> get <*> get -------------------------------------------------------------------------------- instance IsString Identifier where fromString = fromFilePath -------------------------------------------------------------------------------- instance NFData Identifier where rnf (Identifier v p) = rnf v `seq` rnf p `seq` () -------------------------------------------------------------------------------- instance Show Identifier where show i = case identifierVersion i of Nothing -> toFilePath i Just v -> toFilePath i ++ " (" ++ v ++ ")" -------------------------------------------------------------------------------- -- | Parse an identifier from a string fromFilePath :: String -> Identifier fromFilePath = Identifier Nothing . intercalate "/" . filter (not . null) . split' where split' = map dropTrailingPathSeparator . splitPath -------------------------------------------------------------------------------- -- | Convert an identifier to a relative 'FilePath' toFilePath :: Identifier -> FilePath toFilePath = identifierPath -------------------------------------------------------------------------------- setVersion :: Maybe String -> Identifier -> Identifier setVersion v i = i {identifierVersion = v} hakyll-4.4.3.0/src/Hakyll/Core/Item.hs0000644000000000000000000000437612261555376015515 0ustar0000000000000000-------------------------------------------------------------------------------- -- | An item is a combination of some content and its 'Identifier'. This way, we -- can still use the 'Identifier' to access metadata. {-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Core.Item ( Item (..) , itemSetBody , withItemBody ) where -------------------------------------------------------------------------------- import Control.Applicative (Applicative, (<$>), (<*>)) import Data.Binary (Binary (..)) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) import Data.Typeable (Typeable) import Prelude hiding (foldr) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier -------------------------------------------------------------------------------- data Item a = Item { itemIdentifier :: Identifier , itemBody :: a } deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Functor Item where fmap f (Item i x) = Item i (f x) -------------------------------------------------------------------------------- instance Foldable Item where foldr f z (Item _ x) = f x z -------------------------------------------------------------------------------- instance Traversable Item where traverse f (Item i x) = Item i <$> f x -------------------------------------------------------------------------------- instance Binary a => Binary (Item a) where put (Item i x) = put i >> put x get = Item <$> get <*> get -------------------------------------------------------------------------------- itemSetBody :: a -> Item b -> Item a itemSetBody x (Item i _) = Item i x -------------------------------------------------------------------------------- -- | Perform a compiler action on the item body. This is the same as 'traverse', -- but looks less intimidating. -- -- > withItemBody = traverse withItemBody :: (a -> Compiler b) -> Item a -> Compiler (Item b) withItemBody = traverse hakyll-4.4.3.0/src/Hakyll/Core/Logger.hs0000644000000000000000000000632112261555376016026 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs module Hakyll.Core.Logger ( Verbosity (..) , Logger , new , flush , error , header , message , debug ) where -------------------------------------------------------------------------------- import Control.Applicative (pure, (<$>), (<*>)) import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Monad (forever) import Control.Monad.Trans (MonadIO, liftIO) import Prelude hiding (error) -------------------------------------------------------------------------------- data Verbosity = Error | Message | Debug deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- -- | Logger structure. Very complicated. data Logger = Logger { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end , loggerSync :: MVar () -- ^ Used for sync on quit , loggerSink :: String -> IO () -- ^ Out sink , loggerVerbosity :: Verbosity -- ^ Verbosity } -------------------------------------------------------------------------------- -- | Create a new logger new :: Verbosity -> IO Logger new vbty = do logger <- Logger <$> newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty _ <- forkIO $ loggerThread logger return logger where loggerThread logger = forever $ do msg <- readChan $ loggerChan logger case msg of -- Stop: sync Nothing -> putMVar (loggerSync logger) () -- Print and continue Just m -> loggerSink logger m -------------------------------------------------------------------------------- -- | Flush the logger (blocks until flushed) flush :: Logger -> IO () flush logger = do writeChan (loggerChan logger) Nothing () <- takeMVar $ loggerSync logger return () -------------------------------------------------------------------------------- string :: MonadIO m => Logger -- ^ Logger -> Verbosity -- ^ Verbosity of the string -> String -- ^ Section name -> m () -- ^ No result string l v m | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m) | otherwise = return () -------------------------------------------------------------------------------- error :: MonadIO m => Logger -> String -> m () error l m = string l Error $ " [ERROR] " ++ m -------------------------------------------------------------------------------- header :: MonadIO m => Logger -> String -> m () header l = string l Message -------------------------------------------------------------------------------- message :: MonadIO m => Logger -> String -> m () message l m = string l Message $ " " ++ m -------------------------------------------------------------------------------- debug :: MonadIO m => Logger -> String -> m () debug l m = string l Debug $ " [DEBUG] " ++ m hakyll-4.4.3.0/src/Hakyll/Core/Metadata.hs0000644000000000000000000000444312261555376016332 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Metadata ( Metadata , MonadMetadata (..) , getMetadataField , getMetadataField' , makePatternDependency ) where -------------------------------------------------------------------------------- import Control.Monad (forM) import Data.Map (Map) import qualified Data.Map as M -------------------------------------------------------------------------------- import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -------------------------------------------------------------------------------- type Metadata = Map String String -------------------------------------------------------------------------------- class Monad m => MonadMetadata m where getMetadata :: Identifier -> m Metadata getMatches :: Pattern -> m [Identifier] getAllMetadata :: Pattern -> m [(Identifier, Metadata)] getAllMetadata pattern = do matches' <- getMatches pattern forM matches' $ \id' -> do metadata <- getMetadata id' return (id', metadata) -------------------------------------------------------------------------------- getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String) getMetadataField identifier key = do metadata <- getMetadata identifier return $ M.lookup key metadata -------------------------------------------------------------------------------- -- | Version of 'getMetadataField' which throws an error if the field does not -- exist. getMetadataField' :: MonadMetadata m => Identifier -> String -> m String getMetadataField' identifier key = do field <- getMetadataField identifier key case field of Just v -> return v Nothing -> fail $ "Hakyll.Core.Metadata.getMetadataField': " ++ "Item " ++ show identifier ++ " has no metadata field " ++ show key -------------------------------------------------------------------------------- makePatternDependency :: MonadMetadata m => Pattern -> m Dependency makePatternDependency pattern = do matches' <- getMatches pattern return $ PatternDependency pattern matches' hakyll-4.4.3.0/src/Hakyll/Core/Provider.hs0000644000000000000000000000313312261555376016377 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module provides an wrapper API around the file system which does some -- caching. module Hakyll.Core.Provider ( -- * Constructing resource providers Internal.Provider , newProvider -- * Querying resource properties , Internal.resourceList , Internal.resourceExists , Internal.resourceFilePath , Internal.resourceModified , Internal.resourceModificationTime -- * Access to raw resource content , Internal.resourceString , Internal.resourceLBS -- * Access to metadata and body content , Internal.resourceMetadata , Internal.resourceBody ) where -------------------------------------------------------------------------------- import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal import Hakyll.Core.Store (Store) -------------------------------------------------------------------------------- -- | Create a resource provider newProvider :: Store -- ^ Store to use -> (FilePath -> IO Bool) -- ^ Should we ignore this file? -> FilePath -- ^ Search directory -> IO Internal.Provider -- ^ Resulting provider newProvider store ignore directory = do -- Delete metadata cache where necessary p <- Internal.newProvider store ignore directory mapM_ (Internal.resourceInvalidateMetadataCache p) $ filter (Internal.resourceModified p) $ Internal.resourceList p return p hakyll-4.4.3.0/src/Hakyll/Core/Routes.hs0000644000000000000000000001445112261555376016073 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Once a target is compiled, the user usually wants to save it to the disk. -- This is where the 'Routes' type comes in; it determines where a certain -- target should be written. -- -- Suppose we have an item @foo\/bar.markdown@. We can render this to -- @foo\/bar.html@ using: -- -- > route "foo/bar.markdown" (setExtension ".html") -- -- If we do not want to change the extension, we can use 'idRoute', the simplest -- route available: -- -- > route "foo/bar.markdown" idRoute -- -- That will route @foo\/bar.markdown@ to @foo\/bar.markdown@. -- -- Note that the extension says nothing about the content! If you set the -- extension to @.html@, it is your own responsibility to ensure that the -- content is indeed HTML. -- -- Finally, some special cases: -- -- * If there is no route for an item, this item will not be routed, so it will -- not appear in your site directory. -- -- * If an item matches multiple routes, the first rule will be chosen. {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Routes ( UsedMetadata , Routes , runRoutes , idRoute , setExtension , matchRoute , customRoute , constRoute , gsubRoute , metadataRoute , composeRoutes ) where -------------------------------------------------------------------------------- import Data.Monoid (Monoid, mappend, mempty) import System.FilePath (replaceExtension) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Metadata import Hakyll.Core.Provider import Hakyll.Core.Util.String -------------------------------------------------------------------------------- -- | When you ran a route, it's useful to know whether or not this used -- metadata. This allows us to do more granular dependency analysis. type UsedMetadata = Bool -------------------------------------------------------------------------------- data RoutesRead = RoutesRead { routesProvider :: Provider , routesUnderlying :: Identifier } -------------------------------------------------------------------------------- -- | Type used for a route newtype Routes = Routes { unRoutes :: RoutesRead -> Identifier -> IO (Maybe FilePath, UsedMetadata) } -------------------------------------------------------------------------------- instance Monoid Routes where mempty = Routes $ \_ _ -> return (Nothing, False) mappend (Routes f) (Routes g) = Routes $ \p id' -> do (mfp, um) <- f p id' case mfp of Nothing -> g p id' Just _ -> return (mfp, um) -------------------------------------------------------------------------------- -- | Apply a route to an identifier runRoutes :: Routes -> Provider -> Identifier -> IO (Maybe FilePath, UsedMetadata) runRoutes routes provider identifier = unRoutes routes (RoutesRead provider identifier) identifier -------------------------------------------------------------------------------- -- | A route that uses the identifier as filepath. For example, the target with -- ID @foo\/bar@ will be written to the file @foo\/bar@. idRoute :: Routes idRoute = customRoute toFilePath -------------------------------------------------------------------------------- -- | Set (or replace) the extension of a route. -- -- Example: -- -- > runRoutes (setExtension "html") "foo/bar" -- -- Result: -- -- > Just "foo/bar.html" -- -- Example: -- -- > runRoutes (setExtension "html") "posts/the-art-of-trolling.markdown" -- -- Result: -- -- > Just "posts/the-art-of-trolling.html" setExtension :: String -> Routes setExtension extension = customRoute $ (`replaceExtension` extension) . toFilePath -------------------------------------------------------------------------------- -- | Apply the route if the identifier matches the given pattern, fail -- otherwise matchRoute :: Pattern -> Routes -> Routes matchRoute pattern (Routes route) = Routes $ \p id' -> if matches pattern id' then route p id' else return (Nothing, False) -------------------------------------------------------------------------------- -- | Create a custom route. This should almost always be used with -- 'matchRoute' customRoute :: (Identifier -> FilePath) -> Routes customRoute f = Routes $ const $ \id' -> return (Just (f id'), False) -------------------------------------------------------------------------------- -- | A route that always gives the same result. Obviously, you should only use -- this for a single compilation rule. constRoute :: FilePath -> Routes constRoute = customRoute . const -------------------------------------------------------------------------------- -- | Create a gsub route -- -- Example: -- -- > runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" -- -- Result: -- -- > Just "tags/bar.xml" gsubRoute :: String -- ^ Pattern -> (String -> String) -- ^ Replacement -> Routes -- ^ Resulting route gsubRoute pattern replacement = customRoute $ replaceAll pattern replacement . toFilePath -------------------------------------------------------------------------------- -- | Get access to the metadata in order to determine the route metadataRoute :: (Metadata -> Routes) -> Routes metadataRoute f = Routes $ \r i -> do metadata <- resourceMetadata (routesProvider r) (routesUnderlying r) unRoutes (f metadata) r i -------------------------------------------------------------------------------- -- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent -- with @g . f@. -- -- Example: -- -- > let routes = gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml" -- > in runRoutes routes "tags/rss/bar" -- -- Result: -- -- > Just "tags/bar.xml" -- -- If the first route given fails, Hakyll will not apply the second route. composeRoutes :: Routes -- ^ First route to apply -> Routes -- ^ Second route to apply -> Routes -- ^ Resulting route composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do (mfp, um) <- f p i case mfp of Nothing -> return (Nothing, um) Just fp -> do (mfp', um') <- g p (fromFilePath fp) return (mfp', um || um') hakyll-4.4.3.0/src/Hakyll/Core/Rules.hs0000644000000000000000000001546212261555376015707 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module provides a declarative DSL in which the user can specify the -- different rules used to run the compilers. -- -- The convention is to just list all items in the 'Rules' monad, routes and -- compilation rules. -- -- A typical usage example would be: -- -- > main = hakyll $ do -- > match "posts/*" $ do -- > route (setExtension "html") -- > compile someCompiler -- > match "css/*" $ do -- > route idRoute -- > compile compressCssCompiler {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules ( Rules , match , create , version , compile , route -- * Advanced usage , preprocess , Dependency (..) , rulesExtraDependencies ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad.Reader (ask, local) import Control.Monad.State (get, modify, put) import Control.Monad.Trans (liftIO) import Control.Monad.Writer (censor, tell) import Data.Maybe (fromMaybe) import Data.Monoid (mempty) import qualified Data.Set as S -------------------------------------------------------------------------------- import Data.Binary (Binary) import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item import Hakyll.Core.Item.SomeItem import Hakyll.Core.Metadata import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal import Hakyll.Core.Writable -------------------------------------------------------------------------------- -- | Add a route tellRoute :: Routes -> Rules () tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty -------------------------------------------------------------------------------- -- | Add a number of compilers tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules () tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty -------------------------------------------------------------------------------- -- | Add resources tellResources :: [Identifier] -> Rules () tellResources resources' = Rules $ tell $ RuleSet mempty mempty (S.fromList resources') mempty -------------------------------------------------------------------------------- -- | Add a pattern tellPattern :: Pattern -> Rules () tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern -------------------------------------------------------------------------------- flush :: Rules () flush = Rules $ do mcompiler <- rulesCompiler <$> get case mcompiler of Nothing -> return () Just compiler -> do matches' <- rulesMatches <$> ask version' <- rulesVersion <$> ask route' <- fromMaybe mempty . rulesRoute <$> get -- The version is possibly not set correctly at this point (yet) let ids = map (setVersion version') matches' {- ids <- case fromLiteral pattern of Just id' -> return [setVersion version' id'] Nothing -> do ids <- unRules $ getMatches pattern unRules $ tellResources ids return $ map (setVersion version') ids -} -- Create a fast pattern for routing that matches exactly the -- compilers created in the block given to match let fastPattern = fromList ids -- Write out the compilers and routes unRules $ tellRoute $ matchRoute fastPattern route' unRules $ tellCompilers $ [(id', compiler) | id' <- ids] put $ emptyRulesState -------------------------------------------------------------------------------- match :: Pattern -> Rules () -> Rules () match pattern rules = do tellPattern pattern flush ids <- getMatches pattern tellResources ids Rules $ local (setMatches ids) $ unRules $ rules >> flush where setMatches ids env = env {rulesMatches = ids} -------------------------------------------------------------------------------- create :: [Identifier] -> Rules () -> Rules () create ids rules = do flush -- TODO Maybe check if the resources exist and call tellResources on that Rules $ local setMatches $ unRules $ rules >> flush where setMatches env = env {rulesMatches = ids} -------------------------------------------------------------------------------- version :: String -> Rules () -> Rules () version v rules = do flush Rules $ local setVersion' $ unRules $ rules >> flush where setVersion' env = env {rulesVersion = Just v} -------------------------------------------------------------------------------- -- | Add a compilation rule to the rules. -- -- This instructs all resources to be compiled using the given compiler. compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules () compile compiler = Rules $ modify $ \s -> s {rulesCompiler = Just (fmap SomeItem compiler)} -------------------------------------------------------------------------------- -- | Add a route. -- -- This adds a route for all items matching the current pattern. route :: Routes -> Rules () route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'} -------------------------------------------------------------------------------- -- | Execute an 'IO' action immediately while the rules are being evaluated. -- This should be avoided if possible, but occasionally comes in useful. preprocess :: IO a -> Rules a preprocess = Rules . liftIO -------------------------------------------------------------------------------- -- | Advanced usage: add extra dependencies to compilers. Basically this is -- needed when you're doing unsafe tricky stuff in the rules monad, but you -- still want correct builds. -- -- A useful utility for this purpose is 'makePatternDependency'. rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a rulesExtraDependencies deps = Rules . censor addDependencies . unRules where -- Adds the dependencies to the compilers in the ruleset addDependencies ruleSet = ruleSet { rulesCompilers = [ (i, compilerTellDependencies deps >> c) | (i, c) <- rulesCompilers ruleSet ] } hakyll-4.4.3.0/src/Hakyll/Core/Runtime.hs0000644000000000000000000002363112261555376016235 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Runtime ( run ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad (unless) import Control.Monad.Error (ErrorT, runErrorT, throwError) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.State (get, modify) import Control.Monad.Trans (liftIO) import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as M import Data.Monoid (mempty) import Data.Set (Set) import qualified Data.Set as S import System.Exit (ExitCode (..)) import System.FilePath (()) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Compiler.Require import Hakyll.Core.Configuration import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Item.SomeItem import Hakyll.Core.Logger (Logger, Verbosity) import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Provider import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File import Hakyll.Core.Writable -------------------------------------------------------------------------------- run :: Configuration -> Verbosity -> Rules a -> IO (ExitCode, RuleSet) run config verbosity rules = do -- Initialization logger <- Logger.new verbosity Logger.header logger "Initialising..." Logger.message logger "Creating store..." store <- Store.new (inMemoryCache config) $ storeDirectory config Logger.message logger "Creating provider..." provider <- newProvider store (shouldIgnoreFile config) $ providerDirectory config Logger.message logger "Running rules..." ruleSet <- runRules rules provider -- Get old facts mOldFacts <- Store.get store factsKey let (oldFacts) = case mOldFacts of Store.Found f -> f _ -> mempty -- Build runtime read/state let compilers = rulesCompilers ruleSet read' = RuntimeRead { runtimeConfiguration = config , runtimeLogger = logger , runtimeProvider = provider , runtimeStore = store , runtimeRoutes = rulesRoutes ruleSet , runtimeUniverse = M.fromList compilers } state = RuntimeState { runtimeDone = S.empty , runtimeTodo = M.empty , runtimeFacts = oldFacts } -- Run the program and fetch the resulting state result <- runErrorT $ runRWST build read' state case result of Left e -> do Logger.error logger e Logger.flush logger return (ExitFailure 1, ruleSet) Right (_, s, _) -> do Store.set store factsKey $ runtimeFacts s Logger.debug logger "Removing tmp directory..." removeDirectory $ tmpDirectory config Logger.flush logger return (ExitSuccess, ruleSet) where factsKey = ["Hakyll.Core.Runtime.run", "facts"] -------------------------------------------------------------------------------- data RuntimeRead = RuntimeRead { runtimeConfiguration :: Configuration , runtimeLogger :: Logger , runtimeProvider :: Provider , runtimeStore :: Store , runtimeRoutes :: Routes , runtimeUniverse :: Map Identifier (Compiler SomeItem) } -------------------------------------------------------------------------------- data RuntimeState = RuntimeState { runtimeDone :: Set Identifier , runtimeTodo :: Map Identifier (Compiler SomeItem) , runtimeFacts :: DependencyFacts } -------------------------------------------------------------------------------- type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a -------------------------------------------------------------------------------- build :: Runtime () build = do logger <- runtimeLogger <$> ask Logger.header logger "Checking for out-of-date items" scheduleOutOfDate Logger.header logger "Compiling" pickAndChase Logger.header logger "Success" -------------------------------------------------------------------------------- scheduleOutOfDate :: Runtime () scheduleOutOfDate = do logger <- runtimeLogger <$> ask provider <- runtimeProvider <$> ask universe <- runtimeUniverse <$> ask facts <- runtimeFacts <$> get todo <- runtimeTodo <$> get let identifiers = M.keys universe modified = S.fromList $ flip filter identifiers $ resourceModified provider let (ood, facts', msgs) = outOfDate identifiers modified facts todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe -- Print messages mapM_ (Logger.debug logger) msgs -- Update facts and todo items modify $ \s -> s { runtimeDone = runtimeDone s `S.union` (S.fromList identifiers `S.difference` ood) , runtimeTodo = todo `M.union` todo' , runtimeFacts = facts' } -------------------------------------------------------------------------------- pickAndChase :: Runtime () pickAndChase = do todo <- runtimeTodo <$> get case M.minViewWithKey todo of Nothing -> return () Just ((id', _), _) -> do chase [] id' pickAndChase -------------------------------------------------------------------------------- chase :: [Identifier] -> Identifier -> Runtime () chase trail id' | id' `elem` trail = throwError $ "Hakyll.Core.Runtime.chase: " ++ "Dependency cycle detected: " ++ intercalate " depends on " (map show $ dropWhile (/= id') (reverse trail) ++ [id']) | otherwise = do logger <- runtimeLogger <$> ask todo <- runtimeTodo <$> get provider <- runtimeProvider <$> ask universe <- runtimeUniverse <$> ask routes <- runtimeRoutes <$> ask store <- runtimeStore <$> ask config <- runtimeConfiguration <$> ask Logger.debug logger $ "Processing " ++ show id' let compiler = todo M.! id' read' = CompilerRead { compilerConfig = config , compilerUnderlying = id' , compilerProvider = provider , compilerUniverse = M.keysSet universe , compilerRoutes = routes , compilerStore = store , compilerLogger = logger } result <- liftIO $ runCompiler compiler read' case result of -- Rethrow error CompilerError [] -> throwError "Compiler failed but no info given, try running with -v?" CompilerError es -> throwError $ intercalate "; " es -- Huge success CompilerDone (SomeItem item) cwrite -> do -- Print some info let facts = compilerDependencies cwrite cacheHits | compilerCacheHits cwrite <= 0 = "updated" | otherwise = "cached " Logger.message logger $ cacheHits ++ " " ++ show id' -- Sanity check unless (itemIdentifier item == id') $ throwError $ "The compiler yielded an Item with Identifier " ++ show (itemIdentifier item) ++ ", but we were expecting " ++ "an Item with Identifier " ++ show id' ++ " " ++ "(you probably want to call makeItem to solve this problem)" -- Write if necessary (mroute, _) <- liftIO $ runRoutes routes provider id' case mroute of Nothing -> return () Just route -> do let path = destinationDirectory config route liftIO $ makeDirectories path liftIO $ write path item Logger.debug logger $ "Routed to " ++ path -- Save! (For load) liftIO $ save store item -- Update state modify $ \s -> s { runtimeDone = S.insert id' (runtimeDone s) , runtimeTodo = M.delete id' (runtimeTodo s) , runtimeFacts = M.insert id' facts (runtimeFacts s) } -- Try something else first CompilerRequire dep c -> do -- Update the compiler so we don't execute it twice depDone <- (dep `S.member`) . runtimeDone <$> get modify $ \s -> s { runtimeTodo = M.insert id' (if depDone then c else compilerResult result) (runtimeTodo s) } -- If the required item is already compiled, continue, or, start -- chasing that Logger.debug logger $ "Require " ++ show dep ++ ": " ++ (if depDone then "OK" else "chasing") if depDone then chase trail id' else chase (id' : trail) dep hakyll-4.4.3.0/src/Hakyll/Core/Store.hs0000644000000000000000000001533412261555376015707 0ustar0000000000000000-------------------------------------------------------------------------------- -- | A store for storing and retreiving items {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Core.Store ( Store , Result (..) , toMaybe , new , set , get , isMember , delete , hash ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Exception (IOException, handle) import qualified Crypto.Hash.MD5 as MD5 import Data.Binary (Binary, decode, encodeFile) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Cache.LRU.IO as Lru import Data.List (intercalate) import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (TypeRep, Typeable, cast, typeOf) import System.Directory (createDirectoryIfMissing) import System.Directory (doesFileExist, removeFile) import System.FilePath (()) import System.IO (IOMode (..), hClose, openFile) import Text.Printf (printf) -------------------------------------------------------------------------------- -- | Simple wrapper type data Box = forall a. Typeable a => Box a -------------------------------------------------------------------------------- data Store = Store { -- | All items are stored on the filesystem storeDirectory :: FilePath , -- | Optionally, items are also kept in-memory storeMap :: Maybe (Lru.AtomicLRU FilePath Box) } -------------------------------------------------------------------------------- instance Show Store where show _ = "" -------------------------------------------------------------------------------- -- | Result of a store query data Result a = Found a -- ^ Found, result | NotFound -- ^ Not found | WrongType TypeRep TypeRep -- ^ Expected, true type deriving (Show, Eq) -------------------------------------------------------------------------------- -- | Convert result to 'Maybe' toMaybe :: Result a -> Maybe a toMaybe (Found x) = Just x toMaybe _ = Nothing -------------------------------------------------------------------------------- -- | Initialize the store new :: Bool -- ^ Use in-memory caching -> FilePath -- ^ Directory to use for hard disk storage -> IO Store -- ^ Store new inMemory directory = do createDirectoryIfMissing True directory ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing return Store { storeDirectory = directory , storeMap = ref } where csize = Just 500 -------------------------------------------------------------------------------- -- | Auxiliary: add an item to the in-memory cache cacheInsert :: Typeable a => Store -> String -> a -> IO () cacheInsert (Store _ Nothing) _ _ = return () cacheInsert (Store _ (Just lru)) key x = Lru.insert key (Box x) lru -------------------------------------------------------------------------------- -- | Auxiliary: get an item from the in-memory cache cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a) cacheLookup (Store _ Nothing) _ = return NotFound cacheLookup (Store _ (Just lru)) key = do res <- Lru.lookup key lru return $ case res of Nothing -> NotFound Just (Box x) -> case cast x of Just x' -> Found x' Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x) -------------------------------------------------------------------------------- cacheIsMember :: Store -> String -> IO Bool cacheIsMember (Store _ Nothing) _ = return False cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru -------------------------------------------------------------------------------- -- | Auxiliary: delete an item from the in-memory cache cacheDelete :: Store -> String -> IO () cacheDelete (Store _ Nothing) _ = return () cacheDelete (Store _ (Just lru)) key = do _ <- Lru.delete key lru return () -------------------------------------------------------------------------------- -- | Store an item set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO () set store identifier value = do encodeFile (storeDirectory store key) value cacheInsert store key value where key = hash identifier -------------------------------------------------------------------------------- -- | Load an item get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a) get store identifier = do -- First check the in-memory map ref <- cacheLookup store key case ref of -- Not found in the map, try the filesystem NotFound -> do exists <- doesFileExist path if not exists -- Not found in the filesystem either then return NotFound -- Found in the filesystem else do v <- decodeClose cacheInsert store key v return $ Found v -- Found in the in-memory map (or wrong type), just return s -> return s where key = hash identifier path = storeDirectory store key -- 'decodeFile' from Data.Binary which closes the file ASAP decodeClose = do h <- openFile path ReadMode lbs <- BL.hGetContents h BL.length lbs `seq` hClose h return $ decode lbs -------------------------------------------------------------------------------- -- | Strict function isMember :: Store -> [String] -> IO Bool isMember store identifier = do inCache <- cacheIsMember store key if inCache then return True else doesFileExist path where key = hash identifier path = storeDirectory store key -------------------------------------------------------------------------------- -- | Delete an item delete :: Store -> [String] -> IO () delete store identifier = do cacheDelete store key deleteFile $ storeDirectory store key where key = hash identifier -------------------------------------------------------------------------------- -- | Delete a file unless it doesn't exist... deleteFile :: FilePath -> IO () deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile -------------------------------------------------------------------------------- -- | Mostly meant for internal usage hash :: [String] -> String hash = concatMap (printf "%02x") . B.unpack . MD5.hash . T.encodeUtf8 . T.pack . intercalate "/" hakyll-4.4.3.0/src/Hakyll/Core/UnixFilter.hs0000644000000000000000000001237512261555376016706 0ustar0000000000000000-------------------------------------------------------------------------------- -- | A Compiler that supports unix filters. module Hakyll.Core.UnixFilter ( unixFilter , unixFilterLBS ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.DeepSeq (deepseq) import Control.Monad (forM_) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB import Data.IORef (newIORef, readIORef, writeIORef) import Data.Monoid (Monoid, mempty) import System.Exit (ExitCode (..)) import System.IO (Handle, hClose, hFlush, hGetContents, hPutStr, hSetEncoding, localeEncoding) import System.Process -------------------------------------------------------------------------------- import Hakyll.Core.Compiler -------------------------------------------------------------------------------- -- | Use a unix filter as compiler. For example, we could use the 'rev' program -- as a compiler. -- -- > rev :: Compiler String -- > rev = getResourceString >>= withItemBody (unixFilter "rev" []) -- -- A more realistic example: one can use this to call, for example, the sass -- compiler on CSS files. More information about sass can be found here: -- -- -- -- The code is fairly straightforward, given that we use @.scss@ for sass: -- -- > match "style.scss" $ do -- > route $ setExtension "css" -- > compile $ getResourceString >>= -- > withItemBody (unixFilter "sass" ["-s", "--scss"]) >>= -- > return . fmap compressCss unixFilter :: String -- ^ Program name -> [String] -- ^ Program args -> String -- ^ Program input -> Compiler String -- ^ Program output unixFilter = unixFilterWith writer reader where writer handle input = do hSetEncoding handle localeEncoding hPutStr handle input reader handle = do hSetEncoding handle localeEncoding out <- hGetContents handle deepseq out (return out) -------------------------------------------------------------------------------- -- | Variant of 'unixFilter' that should be used for binary files -- -- > match "music.wav" $ do -- > route $ setExtension "ogg" -- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"]) unixFilterLBS :: String -- ^ Program name -> [String] -- ^ Program args -> ByteString -- ^ Program input -> Compiler ByteString -- ^ Program output unixFilterLBS = unixFilterWith LB.hPutStr $ \handle -> do out <- LB.hGetContents handle LB.length out `seq` return out -------------------------------------------------------------------------------- -- | Overloaded compiler unixFilterWith :: Monoid o => (Handle -> i -> IO ()) -- ^ Writer -> (Handle -> IO o) -- ^ Reader -> String -- ^ Program name -> [String] -- ^ Program args -> i -- ^ Program input -> Compiler o -- ^ Program output unixFilterWith writer reader programName args input = do debugCompiler ("Executing external program " ++ programName) (output, err, exitCode) <- unsafeCompiler $ unixFilterIO writer reader programName args input forM_ (lines err) debugCompiler case exitCode of ExitSuccess -> return output ExitFailure e -> fail $ "Hakyll.Core.UnixFilter.unixFilterWith: " ++ unwords (programName : args) ++ " gave exit code " ++ show e -------------------------------------------------------------------------------- -- | Internally used function unixFilterIO :: Monoid o => (Handle -> i -> IO ()) -> (Handle -> IO o) -> String -> [String] -> i -> IO (o, String, ExitCode) unixFilterIO writer reader programName args input = do (Just inh, Just outh, Just errh, pid) <- createProcess (proc programName args) { std_in = CreatePipe , std_out = CreatePipe , std_err = CreatePipe } -- Create boxes lock <- newEmptyMVar outRef <- newIORef mempty errRef <- newIORef "" -- Write the input to the child pipe _ <- forkIO $ writer inh input >> hFlush inh >> hClose inh -- Read from stdout _ <- forkIO $ do out <- reader outh hClose outh writeIORef outRef out putMVar lock () -- Read from stderr _ <- forkIO $ do hSetEncoding errh localeEncoding err <- hGetContents errh _ <- deepseq err (return err) hClose errh writeIORef errRef err putMVar lock () -- Get exit code & return takeMVar lock takeMVar lock exitCode <- waitForProcess pid out <- readIORef outRef err <- readIORef errRef return (out, err, exitCode) hakyll-4.4.3.0/src/Hakyll/Core/Writable.hs0000644000000000000000000000360612261555376016363 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Describes writable items; items that can be saved to the disk {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Hakyll.Core.Writable ( Writable (..) ) where -------------------------------------------------------------------------------- import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import Data.Word (Word8) import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.String (renderHtml) -------------------------------------------------------------------------------- import Hakyll.Core.Item -------------------------------------------------------------------------------- -- | Describes an item that can be saved to the disk class Writable a where -- | Save an item to the given filepath write :: FilePath -> Item a -> IO () -------------------------------------------------------------------------------- instance Writable () where write _ _ = return () -------------------------------------------------------------------------------- instance Writable [Char] where write p = writeFile p . itemBody -------------------------------------------------------------------------------- instance Writable SB.ByteString where write p = SB.writeFile p . itemBody -------------------------------------------------------------------------------- instance Writable LB.ByteString where write p = LB.writeFile p . itemBody -------------------------------------------------------------------------------- instance Writable [Word8] where write p = write p . fmap SB.pack -------------------------------------------------------------------------------- instance Writable Html where write p = write p . fmap renderHtml hakyll-4.4.3.0/src/Hakyll/Core/Compiler/0000755000000000000000000000000012261555376016023 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Compiler/Internal.hs0000644000000000000000000002163312261555376020140 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Internally used compiler module {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module Hakyll.Core.Compiler.Internal ( -- * Types CompilerRead (..) , CompilerWrite (..) , CompilerResult (..) , Compiler (..) , runCompiler -- * Core operations , compilerTell , compilerAsk , compilerThrow , compilerCatch , compilerResult , compilerUnsafeIO -- * Utilities , compilerTellDependencies , compilerTellCacheHits ) where -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..), Applicative (..), (<$>)) import Control.Exception (SomeException, handle) import Control.Monad (forM_) import Control.Monad.Error (MonadError (..)) import Data.Monoid (Monoid (..)) import Data.Set (Set) import qualified Data.Set as S -------------------------------------------------------------------------------- import Hakyll.Core.Configuration import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Logger (Logger) import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Metadata import Hakyll.Core.Provider import Hakyll.Core.Routes import Hakyll.Core.Store -------------------------------------------------------------------------------- -- | Environment in which a compiler runs data CompilerRead = CompilerRead { -- | Main configuration compilerConfig :: Configuration , -- | Underlying identifier compilerUnderlying :: Identifier , -- | Resource provider compilerProvider :: Provider , -- | List of all known identifiers compilerUniverse :: Set Identifier , -- | Site routes compilerRoutes :: Routes , -- | Compiler store compilerStore :: Store , -- | Logger compilerLogger :: Logger } -------------------------------------------------------------------------------- data CompilerWrite = CompilerWrite { compilerDependencies :: [Dependency] , compilerCacheHits :: Int } deriving (Show) -------------------------------------------------------------------------------- instance Monoid CompilerWrite where mempty = CompilerWrite [] 0 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) = CompilerWrite (d1 ++ d2) (h1 + h2) -------------------------------------------------------------------------------- data CompilerResult a where CompilerDone :: a -> CompilerWrite -> CompilerResult a CompilerError :: [String] -> CompilerResult a CompilerRequire :: Identifier -> Compiler a -> CompilerResult a -------------------------------------------------------------------------------- -- | A monad which lets you compile items and takes care of dependency tracking -- for you. newtype Compiler a = Compiler { unCompiler :: CompilerRead -> IO (CompilerResult a) } -------------------------------------------------------------------------------- instance Functor Compiler where fmap f (Compiler c) = Compiler $ \r -> do res <- c r return $ case res of CompilerDone x w -> CompilerDone (f x) w CompilerError e -> CompilerError e CompilerRequire i c' -> CompilerRequire i (fmap f c') {-# INLINE fmap #-} -------------------------------------------------------------------------------- instance Monad Compiler where return x = Compiler $ \_ -> return $ CompilerDone x mempty {-# INLINE return #-} Compiler c >>= f = Compiler $ \r -> do res <- c r case res of CompilerDone x w -> do res' <- unCompiler (f x) r return $ case res' of CompilerDone y w' -> CompilerDone y (w `mappend` w') CompilerError e -> CompilerError e CompilerRequire i c' -> CompilerRequire i $ do compilerTell w -- Save dependencies! c' CompilerError e -> return $ CompilerError e CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f {-# INLINE (>>=) #-} fail = compilerThrow . return {-# INLINE fail #-} -------------------------------------------------------------------------------- instance Applicative Compiler where pure x = return x {-# INLINE pure #-} f <*> x = f >>= \f' -> fmap f' x {-# INLINE (<*>) #-} -------------------------------------------------------------------------------- instance MonadMetadata Compiler where getMetadata = compilerGetMetadata getMatches = compilerGetMatches -------------------------------------------------------------------------------- instance MonadError [String] Compiler where throwError = compilerThrow catchError = compilerCatch -------------------------------------------------------------------------------- runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a) runCompiler compiler read' = handle handler $ unCompiler compiler read' where handler :: SomeException -> IO (CompilerResult a) handler e = return $ CompilerError [show e] -------------------------------------------------------------------------------- instance Alternative Compiler where empty = compilerThrow [] x <|> y = compilerCatch x $ \es -> do logger <- compilerLogger <$> compilerAsk forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $ "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e y {-# INLINE (<|>) #-} -------------------------------------------------------------------------------- compilerAsk :: Compiler CompilerRead compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty {-# INLINE compilerAsk #-} -------------------------------------------------------------------------------- compilerTell :: CompilerWrite -> Compiler () compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps {-# INLINE compilerTell #-} -------------------------------------------------------------------------------- compilerThrow :: [String] -> Compiler a compilerThrow es = Compiler $ \_ -> return $ CompilerError es {-# INLINE compilerThrow #-} -------------------------------------------------------------------------------- compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a compilerCatch (Compiler x) f = Compiler $ \r -> do res <- x r case res of CompilerDone res' w -> return (CompilerDone res' w) CompilerError e -> unCompiler (f e) r CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f)) {-# INLINE compilerCatch #-} -------------------------------------------------------------------------------- -- | Put the result back in a compiler compilerResult :: CompilerResult a -> Compiler a compilerResult x = Compiler $ \_ -> return x {-# INLINE compilerResult #-} -------------------------------------------------------------------------------- compilerUnsafeIO :: IO a -> Compiler a compilerUnsafeIO io = Compiler $ \_ -> do x <- io return $ CompilerDone x mempty {-# INLINE compilerUnsafeIO #-} -------------------------------------------------------------------------------- compilerTellDependencies :: [Dependency] -> Compiler () compilerTellDependencies ds = do logger <- compilerLogger <$> compilerAsk forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d compilerTell mempty {compilerDependencies = ds} {-# INLINE compilerTellDependencies #-} -------------------------------------------------------------------------------- compilerTellCacheHits :: Int -> Compiler () compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch} {-# INLINE compilerTellCacheHits #-} -------------------------------------------------------------------------------- compilerGetMetadata :: Identifier -> Compiler Metadata compilerGetMetadata identifier = do provider <- compilerProvider <$> compilerAsk compilerTellDependencies [IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier -------------------------------------------------------------------------------- compilerGetMatches :: Pattern -> Compiler [Identifier] compilerGetMatches pattern = do universe <- compilerUniverse <$> compilerAsk let matching = filterMatches pattern $ S.toList universe compilerTellDependencies [PatternDependency pattern matching] return matching hakyll-4.4.3.0/src/Hakyll/Core/Compiler/Require.hs0000644000000000000000000001147412261555376020002 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Compiler.Require ( Snapshot , save , saveSnapshot , load , loadSnapshot , loadBody , loadSnapshotBody , loadAll , loadAllSnapshots ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad (when) import Data.Binary (Binary) import qualified Data.Set as S import Data.Typeable -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store -------------------------------------------------------------------------------- -- | Whilst compiling an item, it possible to save multiple snapshots of it, and -- not just the final result. type Snapshot = String -------------------------------------------------------------------------------- save :: (Binary a, Typeable a) => Store -> Item a -> IO () save store item = saveSnapshot store final item -------------------------------------------------------------------------------- -- | Save a specific snapshot of an item, so you can load it later using -- 'loadSnapshot'. saveSnapshot :: (Binary a, Typeable a) => Store -> Snapshot -> Item a -> IO () saveSnapshot store snapshot item = Store.set store (key (itemIdentifier item) snapshot) (itemBody item) -------------------------------------------------------------------------------- -- | Load an item compiled elsewhere. If the required item is not yet compiled, -- the build system will take care of that automatically. load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a) load id' = loadSnapshot id' final -------------------------------------------------------------------------------- -- | Require a specific snapshot of an item. loadSnapshot :: (Binary a, Typeable a) => Identifier -> Snapshot -> Compiler (Item a) loadSnapshot id' snapshot = do store <- compilerStore <$> compilerAsk universe <- compilerUniverse <$> compilerAsk -- Quick check for better error messages when (id' `S.notMember` universe) $ fail notFound compilerTellDependencies [IdentifierDependency id'] compilerResult $ CompilerRequire id' $ do result <- compilerUnsafeIO $ Store.get store (key id' snapshot) case result of Store.NotFound -> fail notFound Store.WrongType e r -> fail $ wrongType e r Store.Found x -> return $ Item id' x where notFound = "Hakyll.Core.Compiler.Require.load: " ++ show id' ++ " (snapshot " ++ snapshot ++ ") was not found in the cache, " ++ "the cache might be corrupted or " ++ "the item you are referring to might not exist" wrongType e r = "Hakyll.Core.Compiler.Require.load: " ++ show id' ++ " (snapshot " ++ snapshot ++ ") was found in the cache, " ++ "but does not have the right type: expected " ++ show e ++ " but got " ++ show r -------------------------------------------------------------------------------- -- | A shortcut for only requiring the body of an item. -- -- > loadBody = fmap itemBody . load loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a loadBody id' = loadSnapshotBody id' final -------------------------------------------------------------------------------- loadSnapshotBody :: (Binary a, Typeable a) => Identifier -> Snapshot -> Compiler a loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot -------------------------------------------------------------------------------- -- | This function allows you to 'load' a dynamic list of items loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a] loadAll pattern = loadAllSnapshots pattern final -------------------------------------------------------------------------------- loadAllSnapshots :: (Binary a, Typeable a) => Pattern -> Snapshot -> Compiler [Item a] loadAllSnapshots pattern snapshot = do matching <- getMatches pattern mapM (\i -> loadSnapshot i snapshot) matching -------------------------------------------------------------------------------- key :: Identifier -> String -> [String] key identifier snapshot = ["Hakyll.Core.Compiler.Require", show identifier, snapshot] -------------------------------------------------------------------------------- final :: Snapshot final = "_final" hakyll-4.4.3.0/src/Hakyll/Core/Identifier/0000755000000000000000000000000012261555376016333 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Identifier/Pattern.hs0000644000000000000000000002520112261555376020304 0ustar0000000000000000-------------------------------------------------------------------------------- -- | As 'Identifier' is used to specify a single item, a 'Pattern' is used to -- specify a list of items. -- -- In most cases, globs are used for patterns. -- -- A very simple pattern of such a pattern is @\"foo\/bar\"@. This pattern will -- only match the exact @foo\/bar@ identifier. -- -- To match more than one identifier, there are different captures that one can -- use: -- -- * @\"*\"@: matches at most one element of an identifier; -- -- * @\"**\"@: matches one or more elements of an identifier. -- -- Some examples: -- -- * @\"foo\/*\"@ will match @\"foo\/bar\"@ and @\"foo\/foo\"@, but not -- @\"foo\/bar\/qux\"@; -- -- * @\"**\"@ will match any identifier; -- -- * @\"foo\/**\"@ will match @\"foo\/bar\"@ and @\"foo\/bar\/qux\"@, but not -- @\"bar\/foo\"@; -- -- * @\"foo\/*.html\"@ will match all HTML files in the @\"foo\/\"@ directory. -- -- The 'capture' function allows the user to get access to the elements captured -- by the capture elements in the pattern. module Hakyll.Core.Identifier.Pattern ( -- * The pattern type Pattern -- * Creating patterns , fromGlob , fromList , fromRegex , fromVersion , hasVersion , hasNoVersion -- * Composing patterns , (.&&.) , (.||.) , complement -- * Applying patterns , matches , filterMatches -- * Capturing strings , capture , fromCapture , fromCaptures ) where -------------------------------------------------------------------------------- import Control.Applicative (pure, (<$>), (<*>)) 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.Monoid (Monoid, mappend, mempty) import Data.Set (Set) import qualified Data.Set as S -------------------------------------------------------------------------------- import GHC.Exts (IsString, fromString) import Text.Regex.TDFA ((=~)) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier -------------------------------------------------------------------------------- -- | Elements of a glob pattern data GlobComponent = Capture | CaptureMany | Literal String deriving (Eq, Show) -------------------------------------------------------------------------------- instance Binary GlobComponent where put Capture = putWord8 0 put CaptureMany = putWord8 1 put (Literal s) = putWord8 2 >> put s get = getWord8 >>= \t -> case t of 0 -> pure Capture 1 -> pure CaptureMany 2 -> Literal <$> get _ -> error "Data.Binary.get: Invalid GlobComponent" -------------------------------------------------------------------------------- -- | Type that allows matching on identifiers data Pattern = Everything | Complement Pattern | And Pattern Pattern | Glob [GlobComponent] | List (Set Identifier) | Regex String | Version (Maybe String) deriving (Show) -------------------------------------------------------------------------------- instance Binary Pattern where put Everything = putWord8 0 put (Complement p) = putWord8 1 >> put p put (And x y) = putWord8 2 >> put x >> put y put (Glob g) = putWord8 3 >> put g put (List is) = putWord8 4 >> put is put (Regex r) = putWord8 5 >> put r put (Version v) = putWord8 6 >> put v get = getWord8 >>= \t -> case t of 0 -> pure Everything 1 -> Complement <$> get 2 -> And <$> get <*> get 3 -> Glob <$> get 4 -> List <$> get 5 -> Regex <$> get _ -> Version <$> get -------------------------------------------------------------------------------- instance IsString Pattern where fromString = fromGlob -------------------------------------------------------------------------------- instance Monoid Pattern where mempty = Everything mappend = (.&&.) -------------------------------------------------------------------------------- -- | Parse a pattern from a string fromGlob :: String -> Pattern fromGlob = Glob . parse' where parse' str = let (chunk, rest) = break (`elem` "\\*") str in case rest of ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs ('*' : xs) -> Literal chunk : Capture : parse' xs xs -> Literal chunk : Literal xs : [] -------------------------------------------------------------------------------- -- | Create a 'Pattern' from a list of 'Identifier's it should match. -- -- /Warning/: use this carefully with 'hasNoVersion' and 'hasVersion'. The -- 'Identifier's in the list /already/ have versions assigned, and the pattern -- will then only match the intersection of both versions. -- -- A more concrete example, -- -- > fromList ["foo.markdown"] .&&. hasVersion "pdf" -- -- will not match anything! The @"foo.markdown"@ 'Identifier' has no version -- assigned, so the LHS of '.&&.' will only match this 'Identifier' with no -- version. The RHS only matches 'Identifier's with version set to @"pdf"@ -- -- hence, this pattern matches nothing. -- -- The correct way to use this is: -- -- > fromList $ map (setVersion $ Just "pdf") ["foo.markdown"] fromList :: [Identifier] -> Pattern fromList = List . S.fromList -------------------------------------------------------------------------------- -- | Create a 'Pattern' from a regex -- -- Example: -- -- > regex "^foo/[^x]*$ fromRegex :: String -> Pattern fromRegex = Regex -------------------------------------------------------------------------------- -- | Create a pattern which matches all items with the given version. fromVersion :: Maybe String -> Pattern fromVersion = Version -------------------------------------------------------------------------------- -- | Specify a version, e.g. -- -- > "foo/*.markdown" .&&. hasVersion "pdf" hasVersion :: String -> Pattern hasVersion = fromVersion . Just -------------------------------------------------------------------------------- -- | Match only if the identifier has no version set, e.g. -- -- > "foo/*.markdown" .&&. hasNoVersion hasNoVersion :: Pattern hasNoVersion = fromVersion Nothing -------------------------------------------------------------------------------- -- | '&&' for patterns: the given identifier must match both subterms (.&&.) :: Pattern -> Pattern -> Pattern x .&&. y = And x y infixr 3 .&&. -------------------------------------------------------------------------------- -- | '||' for patterns: the given identifier must match any subterm (.||.) :: Pattern -> Pattern -> Pattern x .||. y = complement (complement x `And` complement y) -- De Morgan's law infixr 2 .||. -------------------------------------------------------------------------------- -- | Inverts a pattern, e.g. -- -- > complement "foo/bar.html" -- -- will match /anything/ except @\"foo\/bar.html\"@ complement :: Pattern -> Pattern complement = Complement -------------------------------------------------------------------------------- -- | Check if an identifier matches a pattern matches :: Pattern -> Identifier -> Bool matches Everything _ = True matches (Complement p) i = not $ matches p i matches (And x y) i = matches x i && matches y i matches (Glob p) i = isJust $ capture (Glob p) i matches (List l) i = i `S.member` l matches (Regex r) i = toFilePath i =~ r matches (Version v) i = identifierVersion i == v -------------------------------------------------------------------------------- -- | Given a list of identifiers, retain only those who match the given pattern filterMatches :: Pattern -> [Identifier] -> [Identifier] filterMatches = filter . matches -------------------------------------------------------------------------------- -- | Split a list at every possible point, generate a list of (init, tail) -- cases. The result is sorted with inits decreasing in length. splits :: [a] -> [([a], [a])] splits = inits &&& tails >>> uncurry zip >>> reverse -------------------------------------------------------------------------------- -- | Match a glob against a pattern, generating a list of captures capture :: Pattern -> Identifier -> Maybe [String] capture (Glob p) i = capture' p (toFilePath i) capture _ _ = Nothing -------------------------------------------------------------------------------- -- | Internal verion of 'capture' capture' :: [GlobComponent] -> String -> Maybe [String] capture' [] [] = Just [] -- An empty match capture' [] _ = Nothing -- No match capture' (Literal l : ms) str -- Match the literal against the string | l `isPrefixOf` str = capture' ms $ drop (length l) str | otherwise = Nothing capture' (Capture : ms) str = -- Match until the next / let (chunk, rest) = break (== '/') str in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ] capture' (CaptureMany : ms) str = -- Match everything msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ] -------------------------------------------------------------------------------- -- | Create an identifier from a pattern by filling in the captures with a given -- string -- -- Example: -- -- > fromCapture (fromGlob "tags/*") "foo" -- -- Result: -- -- > "tags/foo" fromCapture :: Pattern -> String -> Identifier fromCapture pattern = fromCaptures pattern . repeat -------------------------------------------------------------------------------- -- | Create an identifier from a pattern by filling in the captures with the -- given list of strings fromCaptures :: Pattern -> [String] -> Identifier fromCaptures (Glob p) = fromFilePath . fromCaptures' p fromCaptures _ = error $ "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++ "on simple globs!" -------------------------------------------------------------------------------- -- | Internally used version of 'fromCaptures' fromCaptures' :: [GlobComponent] -> [String] -> String fromCaptures' [] _ = mempty fromCaptures' (m : ms) [] = case m of Literal l -> l `mappend` fromCaptures' ms [] _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': " ++ "identifier list exhausted" fromCaptures' (m : ms) ids@(i : is) = case m of Literal l -> l `mappend` fromCaptures' ms ids _ -> i `mappend` fromCaptures' ms is hakyll-4.4.3.0/src/Hakyll/Core/Item/0000755000000000000000000000000012261555376015147 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Item/SomeItem.hs0000644000000000000000000000145412261555376017231 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} module Hakyll.Core.Item.SomeItem ( SomeItem (..) ) where -------------------------------------------------------------------------------- import Data.Binary (Binary) import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Hakyll.Core.Item import Hakyll.Core.Writable -------------------------------------------------------------------------------- -- | An existential type, mostly for internal usage. data SomeItem = forall a. (Binary a, Typeable a, Writable a) => SomeItem (Item a) deriving (Typeable) hakyll-4.4.3.0/src/Hakyll/Core/Provider/0000755000000000000000000000000012261555376016043 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Provider/Internal.hs0000644000000000000000000001762012261555376020161 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Provider.Internal ( ResourceInfo (..) , Provider (..) , newProvider , resourceList , resourceExists , resourceFilePath , resourceString , resourceLBS , resourceModified , resourceModificationTime ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.DeepSeq (NFData (..), deepseq) import Control.Monad (forM) import Data.Binary (Binary (..)) import qualified Data.ByteString.Lazy as BL import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid (mempty) import Data.Set (Set) import qualified Data.Set as S import Data.Time (Day (..), UTCTime (..), secondsToDiffTime) import Data.Typeable (Typeable) import System.Directory (getModificationTime) import System.FilePath (addExtension, ()) -------------------------------------------------------------------------------- #if !MIN_VERSION_directory(1,2,0) import Data.Time (readTime) import System.Locale (defaultTimeLocale) import System.Time (formatCalendarTime, toCalendarTime) #endif -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File -------------------------------------------------------------------------------- -- | Because UTCTime doesn't have a Binary instance... newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime} deriving (Eq, NFData, Ord, Show, Typeable) -------------------------------------------------------------------------------- instance Binary BinaryTime where put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) = put d >> put (floor dt :: Integer) get = fmap BinaryTime $ UTCTime <$> (ModifiedJulianDay <$> get) <*> (secondsToDiffTime <$> get) -------------------------------------------------------------------------------- data ResourceInfo = ResourceInfo { resourceInfoModified :: BinaryTime , resourceInfoMetadata :: Maybe Identifier } deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Binary ResourceInfo where put (ResourceInfo mtime meta) = put mtime >> put meta get = ResourceInfo <$> get <*> get -------------------------------------------------------------------------------- instance NFData ResourceInfo where rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` () -------------------------------------------------------------------------------- -- | Responsible for retrieving and listing resources data Provider = Provider { -- Top of the provided directory providerDirectory :: FilePath , -- | A list of all files found providerFiles :: Map Identifier ResourceInfo , -- | A list of the files from the previous run providerOldFiles :: Map Identifier ResourceInfo , -- | Underlying persistent store for caching providerStore :: Store } deriving (Show) -------------------------------------------------------------------------------- -- | Create a resource provider newProvider :: Store -- ^ Store to use -> (FilePath -> IO Bool) -- ^ Should we ignore this file? -> FilePath -- ^ Search directory -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do list <- map fromFilePath <$> getRecursiveContents ignore directory let universe = S.fromList list files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do rInfo <- getResourceInfo directory universe identifier return (identifier, rInfo) -- Get the old files from the store, and then immediately replace them by -- the new files. oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey oldFiles `deepseq` Store.set store oldKey files return $ Provider directory files oldFiles store where oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"] -- Update modified if metadata is modified maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) -> let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod} -------------------------------------------------------------------------------- getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo getResourceInfo directory universe identifier = do mtime <- fileModificationTime $ directory toFilePath identifier return $ ResourceInfo (BinaryTime mtime) $ if mdRsc `S.member` universe then Just mdRsc else Nothing where mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier -------------------------------------------------------------------------------- resourceList :: Provider -> [Identifier] resourceList = M.keys . providerFiles -------------------------------------------------------------------------------- -- | Check if a given resource exists resourceExists :: Provider -> Identifier -> Bool resourceExists provider = (`M.member` providerFiles provider) . setVersion Nothing -------------------------------------------------------------------------------- resourceFilePath :: Provider -> Identifier -> FilePath resourceFilePath p i = providerDirectory p toFilePath i -------------------------------------------------------------------------------- -- | Get the raw body of a resource as string resourceString :: Provider -> Identifier -> IO String resourceString p i = readFile $ resourceFilePath p i -------------------------------------------------------------------------------- -- | Get the raw body of a resource of a lazy bytestring resourceLBS :: Provider -> Identifier -> IO BL.ByteString resourceLBS p i = BL.readFile $ resourceFilePath p i -------------------------------------------------------------------------------- -- | A resource is modified if it or its metadata has changed resourceModified :: Provider -> Identifier -> Bool resourceModified p r = case (ri, oldRi) of (Nothing, _) -> False (Just _, Nothing) -> True (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o || resourceInfoMetadata n /= resourceInfoMetadata o where normal = setVersion Nothing r ri = M.lookup normal (providerFiles p) oldRi = M.lookup normal (providerOldFiles p) -------------------------------------------------------------------------------- resourceModificationTime :: Provider -> Identifier -> UTCTime resourceModificationTime p i = case M.lookup (setVersion Nothing i) (providerFiles p) of Just ri -> unBinaryTime $ resourceInfoModified ri Nothing -> error $ "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++ "resource " ++ show i ++ " does not exist" -------------------------------------------------------------------------------- fileModificationTime :: FilePath -> IO UTCTime fileModificationTime fp = do #if MIN_VERSION_directory(1,2,0) getModificationTime fp #else ct <- toCalendarTime =<< getModificationTime fp let str = formatCalendarTime defaultTimeLocale "%s" ct return $ readTime defaultTimeLocale "%s" str #endif hakyll-4.4.3.0/src/Hakyll/Core/Provider/Metadata.hs0000644000000000000000000001142712261555376020124 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Internal module to parse metadata module Hakyll.Core.Provider.Metadata ( loadMetadata , metadata , page -- This parser can be reused in some places , metadataKey ) where -------------------------------------------------------------------------------- import Control.Applicative import Control.Arrow (second) import qualified Data.ByteString.Char8 as BC import Data.List (intercalate) import qualified Data.Map as M import System.IO as IO import Text.Parsec (()) import qualified Text.Parsec as P import Text.Parsec.String (Parser) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal import Hakyll.Core.Util.Parser import Hakyll.Core.Util.String -------------------------------------------------------------------------------- loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String) loadMetadata p identifier = do hasHeader <- probablyHasMetadataHeader fp (md, body) <- if hasHeader then second Just <$> loadMetadataHeader fp else return (M.empty, Nothing) emd <- case mi of Nothing -> return M.empty Just mi' -> loadMetadataFile $ resourceFilePath p mi' return (M.union md emd, body) where normal = setVersion Nothing identifier fp = resourceFilePath p identifier mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata -------------------------------------------------------------------------------- loadMetadataHeader :: FilePath -> IO (Metadata, String) loadMetadataHeader fp = do contents <- readFile fp case P.parse page fp contents of Left err -> error (show err) Right (md, b) -> return (M.fromList md, b) -------------------------------------------------------------------------------- loadMetadataFile :: FilePath -> IO Metadata loadMetadataFile fp = do contents <- readFile fp case P.parse metadata fp contents of Left err -> error (show err) Right md -> return $ M.fromList md -------------------------------------------------------------------------------- -- | Check if a file "probably" has a metadata header. The main goal of this is -- to exclude binary files (which are unlikely to start with "---"). probablyHasMetadataHeader :: FilePath -> IO Bool probablyHasMetadataHeader fp = do handle <- IO.openFile fp IO.ReadMode bs <- BC.hGet handle 1024 IO.hClose handle return $ isMetadataHeader bs where isMetadataHeader bs = let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs in BC.length pre >= 3 && BC.all (== '-') pre -------------------------------------------------------------------------------- -- | Space or tab, no newline inlineSpace :: Parser Char inlineSpace = P.oneOf ['\t', ' '] "space" -------------------------------------------------------------------------------- -- | Parse Windows newlines as well (i.e. "\n" or "\r\n") newline :: Parser String newline = P.string "\n" <|> P.string "\r\n" -------------------------------------------------------------------------------- -- | Parse a single metadata field metadataField :: Parser (String, String) metadataField = do key <- metadataKey _ <- P.char ':' P.skipMany1 inlineSpace "space followed by metadata for: " ++ key value <- P.manyTill P.anyChar newline trailing' <- P.many trailing return (key, trim $ intercalate " " $ value : trailing') where trailing = P.many1 inlineSpace *> P.manyTill P.anyChar newline -------------------------------------------------------------------------------- -- | Parse a metadata block metadata :: Parser [(String, String)] metadata = P.many metadataField -------------------------------------------------------------------------------- -- | Parse a metadata block, including delimiters and trailing newlines metadataBlock :: Parser [(String, String)] metadataBlock = do open <- P.many1 (P.char '-') <* P.many inlineSpace <* newline metadata' <- metadata _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.'] P.skipMany inlineSpace P.skipMany1 newline return metadata' -------------------------------------------------------------------------------- -- | Parse a page consisting of a metadata header and a body page :: Parser ([(String, String)], String) page = do metadata' <- P.option [] metadataBlock body <- P.many P.anyChar return (metadata', body) hakyll-4.4.3.0/src/Hakyll/Core/Provider/MetadataCache.hs0000644000000000000000000000442612261555376021051 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Provider.MetadataCache ( resourceMetadata , resourceBody , resourceInvalidateMetadataCache ) where -------------------------------------------------------------------------------- import Control.Monad (unless) import qualified Data.Map as M -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal import Hakyll.Core.Provider.Metadata import qualified Hakyll.Core.Store as Store -------------------------------------------------------------------------------- resourceMetadata :: Provider -> Identifier -> IO Metadata resourceMetadata p r | not (resourceExists p r) = return M.empty | otherwise = do -- TODO keep time in md cache load p r Store.Found md <- Store.get (providerStore p) [name, toFilePath r, "metadata"] return md -------------------------------------------------------------------------------- resourceBody :: Provider -> Identifier -> IO String resourceBody p r = do load p r Store.Found bd <- Store.get (providerStore p) [name, toFilePath r, "body"] maybe (resourceString p r) return bd -------------------------------------------------------------------------------- resourceInvalidateMetadataCache :: Provider -> Identifier -> IO () resourceInvalidateMetadataCache p r = do Store.delete (providerStore p) [name, toFilePath r, "metadata"] Store.delete (providerStore p) [name, toFilePath r, "body"] -------------------------------------------------------------------------------- load :: Provider -> Identifier -> IO () load p r = do mmof <- Store.isMember store mdk unless mmof $ do (md, body) <- loadMetadata p r Store.set store mdk md Store.set store bk body where store = providerStore p mdk = [name, toFilePath r, "metadata"] bk = [name, toFilePath r, "body"] -------------------------------------------------------------------------------- name :: String name = "Hakyll.Core.Resource.Provider.MetadataCache" hakyll-4.4.3.0/src/Hakyll/Core/Rules/0000755000000000000000000000000012261555376015343 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Rules/Internal.hs0000644000000000000000000000740412261555376017460 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal ( RulesRead (..) , RuleSet (..) , RulesState (..) , emptyRulesState , Rules (..) , runRules ) where -------------------------------------------------------------------------------- import Control.Applicative (Applicative, (<$>)) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.Trans (liftIO) import qualified Data.Map as M import Data.Monoid (Monoid, mappend, mempty) import Data.Set (Set) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item.SomeItem import Hakyll.Core.Metadata import Hakyll.Core.Provider import Hakyll.Core.Routes -------------------------------------------------------------------------------- data RulesRead = RulesRead { rulesProvider :: Provider , rulesMatches :: [Identifier] , rulesVersion :: Maybe String } -------------------------------------------------------------------------------- data RuleSet = RuleSet { -- | Accumulated routes rulesRoutes :: Routes , -- | Accumulated compilers rulesCompilers :: [(Identifier, Compiler SomeItem)] , -- | A set of the actually used files rulesResources :: Set Identifier , -- | A pattern we can use to check if a file *would* be used. This is -- needed for the preview server. rulesPattern :: Pattern } -------------------------------------------------------------------------------- instance Monoid RuleSet where mempty = RuleSet mempty mempty mempty mempty mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) = RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2) -------------------------------------------------------------------------------- data RulesState = RulesState { rulesRoute :: Maybe Routes , rulesCompiler :: Maybe (Compiler SomeItem) } -------------------------------------------------------------------------------- emptyRulesState :: RulesState emptyRulesState = RulesState Nothing Nothing -------------------------------------------------------------------------------- -- | The monad used to compose rules newtype Rules a = Rules { unRules :: RWST RulesRead RuleSet RulesState IO a } deriving (Monad, Functor, Applicative) -------------------------------------------------------------------------------- instance MonadMetadata Rules where getMetadata identifier = Rules $ do provider <- rulesProvider <$> ask liftIO $ resourceMetadata provider identifier getMatches pattern = Rules $ do provider <- rulesProvider <$> ask return $ filterMatches pattern $ resourceList provider -------------------------------------------------------------------------------- -- | Run a Rules monad, resulting in a 'RuleSet' runRules :: Rules a -> Provider -> IO RuleSet runRules rules provider = do (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState -- Ensure compiler uniqueness let ruleSet' = ruleSet { rulesCompilers = M.toList $ M.fromListWith (flip const) (rulesCompilers ruleSet) } return ruleSet' where env = RulesRead { rulesProvider = provider , rulesMatches = [] , rulesVersion = Nothing } hakyll-4.4.3.0/src/Hakyll/Core/Util/0000755000000000000000000000000012261555376015166 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Core/Util/File.hs0000644000000000000000000000431312261555376016402 0ustar0000000000000000-------------------------------------------------------------------------------- -- | A module containing various file utility functions module Hakyll.Core.Util.File ( makeDirectories , getRecursiveContents , removeDirectory ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Control.Monad (filterM, forM, when) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getDirectoryContents, removeDirectoryRecursive) import System.FilePath (takeDirectory, ()) -------------------------------------------------------------------------------- -- | Given a path to a file, try to make the path writable by making -- all directories on the path. makeDirectories :: FilePath -> IO () makeDirectories = createDirectoryIfMissing True . takeDirectory -------------------------------------------------------------------------------- -- | Get all contents of a directory. getRecursiveContents :: (FilePath -> IO Bool) -- ^ Ignore this file/directory -> FilePath -- ^ Directory to search -> IO [FilePath] -- ^ List of files found getRecursiveContents ignore top = go "" where isProper x | x `elem` [".", ".."] = return False | otherwise = not <$> ignore x go dir = do dirExists <- doesDirectoryExist (top dir) if not dirExists then return [] else do names <- filterM isProper =<< getDirectoryContents (top dir) paths <- forM names $ \name -> do let rel = dir name isDirectory <- doesDirectoryExist (top rel) if isDirectory then go rel else return [rel] return $ concat paths -------------------------------------------------------------------------------- removeDirectory :: FilePath -> IO () removeDirectory fp = do e <- doesDirectoryExist fp when e $ removeDirectoryRecursive fp hakyll-4.4.3.0/src/Hakyll/Core/Util/Parser.hs0000644000000000000000000000157612261555376016767 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Parser utilities module Hakyll.Core.Util.Parser ( metadataKey , reservedKeys ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>), (<|>)) import Control.Monad (mzero) import qualified Text.Parsec as P import Text.Parsec.String (Parser) -------------------------------------------------------------------------------- metadataKey :: Parser String metadataKey = do i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf " _-.") if i `elem` reservedKeys then mzero else return i -------------------------------------------------------------------------------- reservedKeys :: [String] reservedKeys = ["if", "else", "endif", "for", "sep", "endfor", "partial"] hakyll-4.4.3.0/src/Hakyll/Core/Util/String.hs0000644000000000000000000000502012261555376016765 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Miscellaneous string manipulation functions. module Hakyll.Core.Util.String ( trim , replaceAll , splitAll , needlePrefix ) where -------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.List (isPrefixOf) import Data.Maybe (listToMaybe) import Text.Regex.TDFA ((=~~)) -------------------------------------------------------------------------------- -- | Trim a string (drop spaces, tabs and newlines at both sides). trim :: String -> String trim = reverse . trim' . reverse . trim' where trim' = dropWhile isSpace -------------------------------------------------------------------------------- -- | A simple (but inefficient) regex replace funcion replaceAll :: String -- ^ Pattern -> (String -> String) -- ^ Replacement (called on capture) -> String -- ^ Source string -> String -- ^ Result replaceAll pattern f source = replaceAll' source where replaceAll' src = case listToMaybe (src =~~ pattern) of Nothing -> src Just (o, l) -> let (before, tmp) = splitAt o src (capture, after) = splitAt l tmp in before ++ f capture ++ replaceAll' after -------------------------------------------------------------------------------- -- | A simple regex split function. The resulting list will contain no empty -- strings. splitAll :: String -- ^ Pattern -> String -- ^ String to split -> [String] -- ^ Result splitAll pattern = filter (not . null) . splitAll' where splitAll' src = case listToMaybe (src =~~ pattern) of Nothing -> [src] Just (o, l) -> let (before, tmp) = splitAt o src in before : splitAll' (drop l tmp) -------------------------------------------------------------------------------- -- | Find the first instance of needle (must be non-empty) in haystack. We -- return the prefix of haystack before needle is matched. -- -- Examples: -- -- > needlePrefix "cd" "abcde" = "ab" -- -- > needlePrefix "ab" "abc" = "" -- -- > needlePrefix "ab" "xxab" = "xx" -- -- > needlePrefix "a" "xx" = "xx" needlePrefix :: String -> String -> Maybe String needlePrefix needle haystack = go [] haystack where go _ [] = Nothing go acc xss@(x:xs) | needle `isPrefixOf` xss = Just $ reverse acc | otherwise = go (x : acc) xs hakyll-4.4.3.0/src/Hakyll/Preview/0000755000000000000000000000000012261555376015002 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Preview/Poll.hs0000644000000000000000000001045012261555376016244 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Hakyll.Preview.Poll ( watchUpdates ) where -------------------------------------------------------------------------------- import Control.Concurrent.MVar (newMVar, putMVar, takeMVar) import Control.Monad (when, void) import Filesystem.Path.CurrentOS (decodeString, encodeString) import System.Directory (canonicalizePath) import System.FilePath (pathSeparators, ()) import System.FSNotify (Event (..), WatchConfig (..), startManagerConf, watchTree) #ifdef mingw32_HOST_OS import System.IO (IOMode(ReadMode), Handle, openFile, hClose) import System.IO.Error (isPermissionError) import Control.Concurrent (threadDelay) import Control.Exception (IOException, throw, try) import System.Exit (exitFailure) import System.Directory (doesFileExist) #endif -------------------------------------------------------------------------------- import Hakyll.Core.Configuration import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -------------------------------------------------------------------------------- -- | A thread that watches for updates in a 'providerDirectory' and recompiles -- a site as soon as any changes occur watchUpdates :: Configuration -> IO Pattern -> IO () watchUpdates conf update = do let providerDir = decodeString $ providerDirectory conf lock <- newMVar () pattern <- update fullProviderDir <- canonicalizePath $ providerDirectory conf manager <- startManagerConf (Debounce 0.1) let allowed event = do -- Absolute path of the changed file. This must be inside provider -- dir, since that's the only dir we're watching. let path = eventPath event relative = dropWhile (`elem` pathSeparators) $ drop (length fullProviderDir) path identifier = fromFilePath relative shouldIgnore <- shouldIgnoreFile conf path return $ not shouldIgnore && matches pattern identifier watchTree manager providerDir (not . isRemove) $ \event -> do () <- takeMVar lock allowed' <- allowed event when allowed' $ update' event (encodeString providerDir) putMVar lock () where #ifndef mingw32_HOST_OS update' _ _ = void update #else update' event provider = do let path = provider eventPath event -- on windows, a 'Modified' event is also sent on file deletion fileExists <- doesFileExist path when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10 -- continuously attempts to open the file in between sleep intervals -- handler is run only once it is able to open the file waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r waitOpen _ _ _ 0 = do putStrLn "[ERROR] Failed to retrieve modified file for regeneration" exitFailure waitOpen path mode handler retries = do res <- try $ openFile path mode :: IO (Either IOException Handle) case res of Left ex -> if isPermissionError ex then do threadDelay 100000 waitOpen path mode handler (retries - 1) else throw ex Right h -> do handled <- handler h hClose h return handled #endif -------------------------------------------------------------------------------- eventPath :: Event -> FilePath eventPath evt = encodeString $ evtPath evt where evtPath (Added p _) = p evtPath (Modified p _) = p evtPath (Removed p _) = p -------------------------------------------------------------------------------- isRemove :: Event -> Bool isRemove (Removed _ _) = True isRemove _ = False hakyll-4.4.3.0/src/Hakyll/Preview/Server.hs0000644000000000000000000000320212261555376016601 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Implements a basic static file server for previewing options {-# LANGUAGE OverloadedStrings #-} module Hakyll.Preview.Server ( staticServer ) where -------------------------------------------------------------------------------- import Control.Monad.Trans (liftIO) import qualified Snap.Core as Snap import qualified Snap.Http.Server as Snap import qualified Snap.Util.FileServe as Snap -------------------------------------------------------------------------------- -- | Serve a given directory static :: FilePath -- ^ Directory to serve -> (FilePath -> IO ()) -- ^ Pre-serve hook -> Snap.Snap () static directory preServe = Snap.serveDirectoryWith directoryConfig directory where directoryConfig :: Snap.DirectoryConfig Snap.Snap directoryConfig = Snap.fancyDirectoryConfig { Snap.preServeHook = liftIO . preServe } -------------------------------------------------------------------------------- -- | Main method, runs a static server in the given directory staticServer :: FilePath -- ^ Directory to serve -> (FilePath -> IO ()) -- ^ Pre-serve hook -> Int -- ^ Port to listen on -> IO () -- ^ Blocks forever staticServer directory preServe port = Snap.httpServe config $ static directory preServe where -- Snap server config config = Snap.setPort port $ Snap.setAccessLog Snap.ConfigNoLog $ Snap.setErrorLog Snap.ConfigNoLog $ Snap.emptyConfig hakyll-4.4.3.0/src/Hakyll/Web/0000755000000000000000000000000012261555376014076 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Web/CompressCss.hs0000644000000000000000000000423412261555376016701 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Module used for CSS compression. The compression is currently in a simple -- state, but would typically reduce the number of bytes by about 25%. module Hakyll.Web.CompressCss ( compressCssCompiler , compressCss ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Data.Char (isSpace) import Data.List (isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item import Hakyll.Core.Util.String -------------------------------------------------------------------------------- -- | Compiler form of 'compressCss' compressCssCompiler :: Compiler (Item String) compressCssCompiler = fmap compressCss <$> getResourceString -------------------------------------------------------------------------------- -- | Compress CSS to speed up your site. compressCss :: String -> String compressCss = compressSeparators . stripComments . compressWhitespace -------------------------------------------------------------------------------- -- | Compresses certain forms of separators. compressSeparators :: String -> String compressSeparators = replaceAll "; *}" (const "}") . replaceAll " *([{};:]) *" (take 1 . dropWhile isSpace) . replaceAll ";+" (const ";") -------------------------------------------------------------------------------- -- | Compresses all whitespace. compressWhitespace :: String -> String compressWhitespace = replaceAll "[ \t\n\r]+" (const " ") -------------------------------------------------------------------------------- -- | Function that strips CSS comments away. stripComments :: String -> String stripComments [] = [] stripComments str | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str | otherwise = head str : stripComments (drop 1 str) where eatComments str' | null str' = [] | isPrefixOf "*/" str' = drop 2 str' | otherwise = eatComments $ drop 1 str' hakyll-4.4.3.0/src/Hakyll/Web/Feed.hs0000644000000000000000000001213612261555376015300 0ustar0000000000000000-------------------------------------------------------------------------------- -- | A Module that allows easy rendering of RSS feeds. -- -- The main rendering functions (@renderRss@, @renderAtom@) all assume that -- you pass the list of items so that the most recent entry in the feed is the -- first item in the list. -- -- Also note that the context should have (at least) the following fields to -- produce a correct feed: -- -- - @$title$@: Title of the item -- -- - @$description$@: Description to appear in the feed -- -- - @$url$@: URL to the item - this is usually set automatically. -- -- In addition, the posts should be named according to the rules for -- 'Hakyll.Web.Template.Context.dateField' module Hakyll.Web.Feed ( FeedConfiguration (..) , renderRss , renderAtom ) where -------------------------------------------------------------------------------- import Control.Monad ((<=<)) import Data.Monoid (mconcat) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Item import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.List import Hakyll.Web.Template.Read -------------------------------------------------------------------------------- import Paths_hakyll -------------------------------------------------------------------------------- -- | This is a data structure to keep the configuration of a feed. data FeedConfiguration = FeedConfiguration { -- | Title of the feed. feedTitle :: String , -- | Description of the feed. feedDescription :: String , -- | Name of the feed author. feedAuthorName :: String , -- | Email of the feed author. feedAuthorEmail :: String , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@) feedRoot :: String } deriving (Show, Eq) -------------------------------------------------------------------------------- -- | Abstract function to render any feed. renderFeed :: FilePath -- ^ Feed template -> FilePath -- ^ Item template -> FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Context for the items -> [Item String] -- ^ Input items -> Compiler (Item String) -- ^ Resulting item renderFeed feedPath itemPath config itemContext items = do feedTpl <- compilerUnsafeIO $ loadTemplate feedPath itemTpl <- compilerUnsafeIO $ loadTemplate itemPath body <- makeItem =<< applyTemplateList itemTpl itemContext' items applyTemplate feedTpl feedContext body where -- Auxiliary: load a template from a datafile loadTemplate = fmap readTemplate . readFile <=< getDataFileName itemContext' = mconcat [ constField "root" (feedRoot config) , itemContext ] feedContext = mconcat [ bodyField "body" , constField "title" (feedTitle config) , constField "description" (feedDescription config) , constField "authorName" (feedAuthorName config) , constField "authorEmail" (feedAuthorEmail config) , constField "root" (feedRoot config) , urlField "url" , updatedField , missingField ] -- Take the first "updated" field from all items -- this should be the most -- recent. updatedField = field "updated" $ \_ -> case items of [] -> return "Unknown" (x : _) -> unContext itemContext' "updated" x >>= \cf -> case cf of ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error" StringField s -> return s -------------------------------------------------------------------------------- -- | Render an RSS feed with a number of items. renderRss :: FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Item context -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed renderRss config context = renderFeed "templates/rss.xml" "templates/rss-item.xml" config (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context) -------------------------------------------------------------------------------- -- | Render an Atom feed with a number of items. renderAtom :: FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Item context -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed renderAtom config context = renderFeed "templates/atom.xml" "templates/atom-item.xml" config (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context) -------------------------------------------------------------------------------- -- | Copies @$updated$@ from @$published$@ if it is not already set. makeItemContext :: String -> Context a -> Context a makeItemContext fmt context = mconcat [dateField "published" fmt, context, dateField "updated" fmt] hakyll-4.4.3.0/src/Hakyll/Web/Html.hs0000644000000000000000000001246112261555376015342 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Provides utilities to manipulate HTML pages module Hakyll.Web.Html ( -- * Generic withTags -- * Headers , demoteHeaders -- * Url manipulation , getUrls , withUrls , toUrl , toSiteRoot , isExternal -- * Stripping/escaping , stripTags , escapeHtml ) where -------------------------------------------------------------------------------- import Data.Char (digitToInt, intToDigit, isDigit, toLower) import Data.List (isPrefixOf) import qualified Data.Set as S import System.FilePath.Posix (joinPath, splitPath, takeDirectory) import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Text.HTML.TagSoup as TS import Network.URI (isUnreserved, escapeURIString) -------------------------------------------------------------------------------- -- | Map over all tags in the document withTags :: (TS.Tag String -> TS.Tag String) -> String -> String withTags f = renderTags' . map f . TS.parseTags -------------------------------------------------------------------------------- -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc. demoteHeaders :: String -> String demoteHeaders = withTags $ \tag -> case tag of TS.TagOpen t a -> TS.TagOpen (demote t) a TS.TagClose t -> TS.TagClose (demote t) t -> t where demote t@['h', n] | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)] | otherwise = t demote t = t -------------------------------------------------------------------------------- isUrlAttribute :: String -> Bool isUrlAttribute = (`elem` ["src", "href", "data"]) -------------------------------------------------------------------------------- getUrls :: [TS.Tag String] -> [String] getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k] -------------------------------------------------------------------------------- -- | Apply a function to each URL on a webpage withUrls :: (String -> String) -> String -> String withUrls f = withTags tag where tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a tag x = x attr (k, v) = (k, if isUrlAttribute k then f v else v) -------------------------------------------------------------------------------- -- | Customized TagSoup renderer. The default TagSoup renderer escape CSS -- within style tags, and doesn't properly minimize. renderTags' :: [TS.Tag String] -> String renderTags' = TS.renderTagsOptions TS.renderOptions { TS.optRawTag = (`elem` ["script", "style"]) . map toLower , TS.optMinimize = (`S.member` minimize) . map toLower } where -- A list of elements which must be minimized minimize = S.fromList [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link" , "param" ] -------------------------------------------------------------------------------- -- | Convert a filepath to an URL starting from the site root -- -- Example: -- -- > toUrl "foo/bar.html" -- -- Result: -- -- > "/foo/bar.html" -- -- This also sanitizes the URL, e.g. converting spaces into '%20' toUrl :: FilePath -> String toUrl url = case url of ('/' : xs) -> '/' : sanitize xs xs -> '/' : sanitize xs where -- Everything but unreserved characters should be escaped as we are -- sanitising the path therefore reserved characters which have a -- meaning in URI does not appear. Special casing for `/`, because it has -- a special meaning in FilePath as well as in URI. sanitize = escapeURIString (\c -> c == '/' || isUnreserved c) -------------------------------------------------------------------------------- -- | Get the relative url to the site root, for a given (absolute) url toSiteRoot :: String -> String toSiteRoot = emptyException . joinPath . map parent . filter relevant . splitPath . takeDirectory where parent = const ".." emptyException [] = "." emptyException x = x relevant "." = False relevant "/" = False relevant _ = True -------------------------------------------------------------------------------- -- | Check if an URL links to an external HTTP(S) source isExternal :: String -> Bool isExternal url = any (flip isPrefixOf url) ["http://", "https://", "//"] -------------------------------------------------------------------------------- -- | Strip all HTML tags from a string -- -- Example: -- -- > stripTags "

foo

" -- -- Result: -- -- > "foo" -- -- This also works for incomplete tags -- -- Example: -- -- > stripTags "

foo "foo" stripTags :: String -> String stripTags [] = [] stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs stripTags (x : xs) = x : stripTags xs -------------------------------------------------------------------------------- -- | HTML-escape a string -- -- Example: -- -- > escapeHtml "Me & Dean" -- -- Result: -- -- > "Me & Dean" escapeHtml :: String -> String escapeHtml = renderHtml . toHtml hakyll-4.4.3.0/src/Hakyll/Web/Paginate.hs0000644000000000000000000001233012261555376016161 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Paginate ( PageNumber , Paginate (..) , buildPaginate , buildPaginateWith , paginateRules , paginateContext ) where -------------------------------------------------------------------------------- import Control.Monad (forM_) import Data.List (unfoldr) import qualified Data.Map as M import Data.Monoid (mconcat) import Text.Printf (printf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Rules import Hakyll.Web.Html import Hakyll.Web.Template.Context -------------------------------------------------------------------------------- type PageNumber = Int -------------------------------------------------------------------------------- -- | Data about paginators data Paginate = Paginate { paginatePages :: M.Map PageNumber [Identifier] , paginatePlaces :: M.Map Identifier PageNumber , paginateMakeId :: PageNumber -> Identifier , paginateDependency :: Dependency } deriving (Show) -------------------------------------------------------------------------------- buildPaginate :: MonadMetadata m => Pattern -> m Paginate buildPaginate pattern = do idents <- getMatches pattern let pagPages = M.fromList $ zip [1 ..] (map return idents) pagPlaces = M.fromList $ zip idents [1 ..] makeId pn = case M.lookup pn pagPages of Just [id'] -> id' _ -> error $ "Hakyll.Web.Paginate.buildPaginate: " ++ "invalid page number: " ++ show pn return $ Paginate pagPages pagPlaces makeId (PatternDependency pattern idents) -------------------------------------------------------------------------------- buildPaginateWith :: MonadMetadata m => Int -> (PageNumber -> Identifier) -> Pattern -> m Paginate buildPaginateWith n makeId pattern = do -- TODO: there is no sensible order for `ids` here, for now it's random; -- but it should be `resectFirst` order because most recent posts should -- correspond to 1st paginator page and oldest one to last page idents <- getMatches pattern let pages = flip unfoldr idents $ \xs -> if null xs then Nothing else Just (splitAt n xs) nPages = length pages paginatePages' = zip [1..] pages pagPlaces' = [(ident, idx) | (idx,ids) <- paginatePages', ident <- ids] ++ [(makeId i, i) | i <- [1 .. nPages]] return $ Paginate (M.fromList paginatePages') (M.fromList pagPlaces') makeId (PatternDependency pattern idents) -------------------------------------------------------------------------------- paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules () paginateRules paginator rules = forM_ (M.toList $ paginatePages paginator) $ \(idx, identifiers) -> create [paginateMakeId paginator idx] $ rulesExtraDependencies [paginateDependency paginator] $ rules idx $ fromList identifiers -------------------------------------------------------------------------------- -- | Takes first, current, last page and produces index of next page type RelPage = PageNumber -> PageNumber -> PageNumber -> Maybe PageNumber -------------------------------------------------------------------------------- paginateField :: Paginate -> String -> RelPage -> Context a paginateField pag fieldName relPage = field fieldName $ \item -> let identifier = itemIdentifier item in case M.lookup identifier (paginatePlaces pag) of Nothing -> fail $ printf "Hakyll.Web.Paginate: there is no page %s in paginator map." (show identifier) Just pos -> case relPage 1 pos nPages of Nothing -> fail "Hakyll.Web.Paginate: No page here." Just pos' -> do let nextId = paginateMakeId pag pos' mroute <- getRoute nextId case mroute of Nothing -> fail $ printf "Hakyll.Web.Paginate: unable to get route for %s." (show nextId) Just rt -> return $ toUrl rt where nPages = M.size (paginatePages pag) -------------------------------------------------------------------------------- paginateContext :: Paginate -> Context a paginateContext pag = mconcat [ paginateField pag "firstPage" (\f c _ -> if c <= f then Nothing else Just f) , paginateField pag "previousPage" (\f c _ -> if c <= f then Nothing else Just (c - 1)) , paginateField pag "nextPage" (\_ c l -> if c >= l then Nothing else Just (c + 1)) , paginateField pag "lastPage" (\_ c l -> if c >= l then Nothing else Just l) ] hakyll-4.4.3.0/src/Hakyll/Web/Pandoc.hs0000644000000000000000000001257312261555376015646 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Module exporting convenient pandoc bindings module Hakyll.Web.Pandoc ( -- * The basic building blocks readPandoc , readPandocWith , writePandoc , writePandocWith , renderPandoc , renderPandocWith -- * Derived compilers , pandocCompiler , pandocCompilerWith , pandocCompilerWithTransform -- * Default options , defaultHakyllReaderOptions , defaultHakyllWriterOptions ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import qualified Data.Set as S import Text.Pandoc -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item import Hakyll.Web.Pandoc.FileType -------------------------------------------------------------------------------- -- | Read a string using pandoc, with the default options readPandoc :: Item String -- ^ String to read -> Item Pandoc -- ^ Resulting document readPandoc = readPandocWith defaultHakyllReaderOptions -------------------------------------------------------------------------------- -- | Read a string using pandoc, with the supplied options readPandocWith :: ReaderOptions -- ^ Parser options -> Item String -- ^ String to read -> Item Pandoc -- ^ Resulting document readPandocWith ropt item = fmap (reader ropt (itemFileType item)) item where reader ro t = case t of Html -> readHtml ro LaTeX -> readLaTeX ro LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t' Markdown -> readMarkdown ro Rst -> readRST ro Textile -> readTextile ro _ -> error $ "Hakyll.Web.readPandocWith: I don't know how to read a file of " ++ "the type " ++ show t ++ " for: " ++ show (itemIdentifier item) addExt ro e = ro {readerExtensions = S.insert e $ readerExtensions ro} -------------------------------------------------------------------------------- -- | Write a document (as HTML) using pandoc, with the default options writePandoc :: Item Pandoc -- ^ Document to write -> Item String -- ^ Resulting HTML writePandoc = writePandocWith defaultHakyllWriterOptions -------------------------------------------------------------------------------- -- | Write a document (as HTML) using pandoc, with the supplied options writePandocWith :: WriterOptions -- ^ Writer options for pandoc -> Item Pandoc -- ^ Document to write -> Item String -- ^ Resulting HTML writePandocWith wopt = fmap $ writeHtmlString wopt -------------------------------------------------------------------------------- -- | Render the resource using pandoc renderPandoc :: Item String -> Item String renderPandoc = renderPandocWith defaultHakyllReaderOptions defaultHakyllWriterOptions -------------------------------------------------------------------------------- -- | Render the resource using pandoc renderPandocWith :: ReaderOptions -> WriterOptions -> Item String -> Item String renderPandocWith ropt wopt = writePandocWith wopt . readPandocWith ropt -------------------------------------------------------------------------------- -- | Read a page render using pandoc pandocCompiler :: Compiler (Item String) pandocCompiler = pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions -------------------------------------------------------------------------------- -- | A version of 'pandocCompiler' which allows you to specify your own pandoc -- options pandocCompilerWith :: ReaderOptions -> WriterOptions -> Compiler (Item String) pandocCompilerWith ropt wopt = pandocCompilerWithTransform ropt wopt id -------------------------------------------------------------------------------- -- | An extension of 'pandocCompilerWith' which allows you to specify a custom -- pandoc transformation for the content pandocCompilerWithTransform :: ReaderOptions -> WriterOptions -> (Pandoc -> Pandoc) -> Compiler (Item String) pandocCompilerWithTransform ropt wopt f = cached cacheName $ writePandocWith wopt . fmap f . readPandocWith ropt <$> getResourceBody where cacheName = "Hakyll.Web.Page.pageCompilerWithPandoc" -------------------------------------------------------------------------------- -- | The default reader options for pandoc parsing in hakyll defaultHakyllReaderOptions :: ReaderOptions defaultHakyllReaderOptions = def { -- The following option causes pandoc to read smart typography, a nice -- and free bonus. readerSmart = True } -------------------------------------------------------------------------------- -- | The default writer options for pandoc rendering in hakyll defaultHakyllWriterOptions :: WriterOptions defaultHakyllWriterOptions = def { -- This option causes literate haskell to be written using '>' marks in -- html, which I think is a good default. writerExtensions = S.insert Ext_literate_haskell (writerExtensions def) , -- We want to have hightlighting by default, to be compatible with earlier -- Hakyll releases writerHighlight = True } hakyll-4.4.3.0/src/Hakyll/Web/Tags.hs0000644000000000000000000003140712261555376015335 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module containing some specialized functions to deal with tags. It -- assumes you follow some conventions. -- -- We support two types of tags: tags and categories. -- -- To use default tags, use 'buildTags'. Tags are placed in a comma-separated -- metadata field like this: -- -- > --- -- > author: Philip K. Dick -- > title: Do androids dream of electric sheep? -- > tags: future, science fiction, humanoid -- > --- -- > The novel is set in a post-apocalyptic near future, where the Earth and -- > its populations have been damaged greatly by Nuclear... -- -- To use categories, use the 'buildCategories' function. Categories are -- determined by the directory a page is in, for example, the post -- -- > posts/coding/2010-01-28-hakyll-categories.markdown -- -- will receive the @coding@ category. -- -- Advanced users may implement custom systems using 'buildTagsWith' if desired. -- -- In the above example, we would want to create a page which lists all pages in -- the @coding@ category, for example, with the 'Identifier': -- -- > tags/coding.html -- -- This is where the first parameter of 'buildTags' and 'buildCategories' comes -- in. In the above case, we used the function: -- -- > fromCapture "tags/*.html" :: String -> Identifier -- -- The 'tagsRules' function lets you generate such a page for each tag in the -- 'Rules' monad. {-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Tags ( Tags (..) , getTags , buildTagsWith , buildTags , buildCategories , tagsRules , renderTags , renderTagCloud , renderTagCloudWith , tagCloudField , tagCloudFieldWith , renderTagList , tagsField , tagsFieldWith , categoryField , sortTagsBy , caseInsensitiveTags ) where -------------------------------------------------------------------------------- import Control.Arrow ((&&&)) import Control.Monad (foldM, forM, forM_) import Data.Char (toLower) import Data.List (intercalate, intersperse, sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (mconcat) import Data.Ord (comparing) import System.FilePath (takeBaseName, takeDirectory) import Text.Blaze.Html (toHtml, toValue, (!)) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Rules import Hakyll.Core.Util.String import Hakyll.Web.Template.Context import Hakyll.Web.Html -------------------------------------------------------------------------------- -- | Data about tags data Tags = Tags { tagsMap :: [(String, [Identifier])] , tagsMakeId :: String -> Identifier , tagsDependency :: Dependency } deriving (Show) -------------------------------------------------------------------------------- -- | Obtain tags from a page in the default way: parse them from the @tags@ -- metadata field. getTags :: MonadMetadata m => Identifier -> m [String] getTags identifier = do metadata <- getMetadata identifier return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata -------------------------------------------------------------------------------- -- | Obtain categories from a page. getCategory :: MonadMetadata m => Identifier -> m [String] getCategory = return . return . takeBaseName . takeDirectory . toFilePath -------------------------------------------------------------------------------- -- | Higher-order function to read tags buildTagsWith :: MonadMetadata m => (Identifier -> m [String]) -> Pattern -> (String -> Identifier) -> m Tags buildTagsWith f pattern makeId = do ids <- getMatches pattern tagMap <- foldM addTags M.empty ids return $ Tags (M.toList tagMap) makeId (PatternDependency pattern ids) where -- Create a tag map for one page addTags tagMap id' = do tags <- f id' let tagMap' = M.fromList $ zip tags $ repeat [id'] return $ M.unionWith (++) tagMap tagMap' -------------------------------------------------------------------------------- buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags buildTags = buildTagsWith getTags -------------------------------------------------------------------------------- buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags buildCategories = buildTagsWith getCategory -------------------------------------------------------------------------------- tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules () tagsRules tags rules = forM_ (tagsMap tags) $ \(tag, identifiers) -> create [tagsMakeId tags tag] $ rulesExtraDependencies [tagsDependency tags] $ rules tag $ fromList identifiers -------------------------------------------------------------------------------- -- | Render tags in HTML (the flexible higher-order function) renderTags :: (String -> String -> Int -> Int -> Int -> String) -- ^ Produce a tag item: tag, url, count, min count, max count -> ([String] -> String) -- ^ Join items -> Tags -- ^ Tag cloud renderer -> Compiler String renderTags makeHtml concatHtml tags = do -- In tags' we create a list: [((tag, route), count)] tags' <- forM (tagsMap tags) $ \(tag, ids) -> do route' <- getRoute $ tagsMakeId tags tag return ((tag, route'), length ids) -- TODO: We actually need to tell a dependency here! let -- Absolute frequencies of the pages freqs = map snd tags' -- The minimum and maximum count found (min', max') | null freqs = (0, 1) | otherwise = (minimum &&& maximum) freqs -- Create a link for one item makeHtml' ((tag, url), count) = makeHtml tag (toUrl $ fromMaybe "/" url) count min' max' -- Render and return the HTML return $ concatHtml $ map makeHtml' tags' -------------------------------------------------------------------------------- -- | Render a tag cloud in HTML renderTagCloud :: Double -- ^ Smallest font size, in percent -> Double -- ^ Biggest font size, in percent -> Tags -- ^ Input tags -> Compiler String -- ^ Rendered cloud renderTagCloud = renderTagCloudWith makeLink (intercalate " ") where makeLink minSize maxSize tag url count min' max' = -- Show the relative size of one 'count' in percent let diff = 1 + fromIntegral max' - fromIntegral min' relative = (fromIntegral count - fromIntegral min') / diff size = floor $ minSize + relative * (maxSize - minSize) :: Int in renderHtml $ H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%") ! A.href (toValue url) $ toHtml tag -------------------------------------------------------------------------------- -- | Render a tag cloud in HTML renderTagCloudWith :: (Double -> Double -> String -> String -> Int -> Int -> Int -> String) -- ^ Render a single tag link -> ([String] -> String) -- ^ Concatenate links -> Double -- ^ Smallest font size, in percent -> Double -- ^ Biggest font size, in percent -> Tags -- ^ Input tags -> Compiler String -- ^ Rendered cloud renderTagCloudWith makeLink cat minSize maxSize = renderTags (makeLink minSize maxSize) cat -------------------------------------------------------------------------------- -- | Render a tag cloud in HTML as a context tagCloudField :: String -- ^ Destination key -> Double -- ^ Smallest font size, in percent -> Double -- ^ Biggest font size, in percent -> Tags -- ^ Input tags -> Context a -- ^ Context tagCloudField key minSize maxSize tags = field key $ \_ -> renderTagCloud minSize maxSize tags -------------------------------------------------------------------------------- -- | Render a tag cloud in HTML as a context tagCloudFieldWith :: String -- ^ Destination key -> (Double -> Double -> String -> String -> Int -> Int -> Int -> String) -- ^ Render a single tag link -> ([String] -> String) -- ^ Concatenate links -> Double -- ^ Smallest font size, in percent -> Double -- ^ Biggest font size, in percent -> Tags -- ^ Input tags -> Context a -- ^ Context tagCloudFieldWith key makeLink cat minSize maxSize tags = field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags -------------------------------------------------------------------------------- -- | Render a simple tag list in HTML, with the tag count next to the item -- TODO: Maybe produce a Context here renderTagList :: Tags -> Compiler (String) renderTagList = renderTags makeLink (intercalate ", ") where makeLink tag url count _ _ = renderHtml $ H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")") -------------------------------------------------------------------------------- -- | Render tags with links with custom functions to get tags and to -- render links tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags -> (String -> (Maybe FilePath) -> Maybe H.Html) -- ^ Render link for one tag -> ([H.Html] -> H.Html) -- ^ Concatenate tag links -> String -- ^ Destination field -> Tags -- ^ Tags structure -> Context a -- ^ Resulting context tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do tags' <- getTags' $ itemIdentifier item links <- forM tags' $ \tag -> do route' <- getRoute $ tagsMakeId tags tag return $ renderLink tag route' return $ renderHtml $ cat $ catMaybes $ links -------------------------------------------------------------------------------- -- | Render tags with links tagsField :: String -- ^ Destination key -> Tags -- ^ Tags -> Context a -- ^ Context tagsField = tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ") -------------------------------------------------------------------------------- -- | Render the category in a link categoryField :: String -- ^ Destination key -> Tags -- ^ Tags -> Context a -- ^ Context categoryField = tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ") -------------------------------------------------------------------------------- -- | Render one tag link simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html simpleRenderLink _ Nothing = Nothing simpleRenderLink tag (Just filePath) = Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag -------------------------------------------------------------------------------- -- | Sort tags using supplied function. First element of the tuple passed to -- the comparing function is the actual tag name. sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering) -> Tags -> Tags sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)} -------------------------------------------------------------------------------- -- | Sample sorting function that compares tags case insensitively. caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier]) -> Ordering caseInsensitiveTags = comparing $ map toLower . fst hakyll-4.4.3.0/src/Hakyll/Web/Template.hs0000644000000000000000000001252412261555376016211 0ustar0000000000000000-- | This module provides means for reading and applying 'Template's. -- -- Templates are tools to convert items into a string. They are perfectly suited -- for laying out your site. -- -- Let's look at an example template: -- -- > -- > -- > My crazy homepage - $title$ -- > -- > -- >

-- >
-- > $body$ -- >
-- > -- > -- > -- -- As you can see, the format is very simple -- @$key$@ is used to render the -- @$key$@ field from the page, everything else is literally copied. If you want -- to literally insert @\"$key$\"@ into your page (for example, when you're -- writing a Hakyll tutorial) you can use -- -- >

-- > A literal $$key$$. -- >

-- -- Because of it's simplicity, these templates can be used for more than HTML: -- you could make, for example, CSS or JS templates as well. module Hakyll.Web.Template ( Template , templateCompiler , applyTemplate , loadAndApplyTemplate , applyAsTemplate ) where -------------------------------------------------------------------------------- import Control.Monad (liftM) import Control.Monad.Error (MonadError (..)) import Data.List (intercalate) import Data.Monoid (mappend) import Prelude hiding (id) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read -------------------------------------------------------------------------------- -- | Read a template. templateCompiler :: Compiler (Item Template) templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do item <- getResourceString return $ fmap readTemplate item -------------------------------------------------------------------------------- applyTemplate :: Template -- ^ Template -> Context a -- ^ Context -> Item a -- ^ Page -> Compiler (Item String) -- ^ Resulting item applyTemplate tpl context item = do body <- applyTemplate' tpl context item return $ itemSetBody body item -------------------------------------------------------------------------------- applyTemplate' :: Template -- ^ Template -> Context a -- ^ Context -> Item a -- ^ Page -> Compiler String -- ^ Resulting item applyTemplate' tpl context x = go tpl where context' = unContext (context `mappend` missingField) go = liftM concat . mapM applyElem . unTemplate applyElem (Chunk c) = return c applyElem Escaped = return "$" applyElem (Key k) = context' k x >>= getString k applyElem (If k t mf) = (context' k x >> go t) `catchError` handler where handler _ = case mf of Nothing -> return "" Just f -> go f applyElem (For k b s) = context' k x >>= \cf -> case cf of StringField _ -> fail $ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++ "got StringField for key " ++ show k ListField c xs -> do sep <- maybe (return "") go s bs <- mapM (applyTemplate' b c) xs return $ intercalate sep bs applyElem (Partial p) = do tpl' <- loadBody (fromFilePath p) applyTemplate' tpl' context x getString _ (StringField s) = return s getString k (ListField _ _) = fail $ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ "got ListField for key " ++ show k -------------------------------------------------------------------------------- -- | The following pattern is so common: -- -- > tpl <- loadBody "templates/foo.html" -- > someCompiler -- > >>= applyTemplate tpl context -- -- That we have a single function which does this: -- -- > someCompiler -- > >>= loadAndApplyTemplate "templates/foo.html" context loadAndApplyTemplate :: Identifier -- ^ Template identifier -> Context a -- ^ Context -> Item a -- ^ Page -> Compiler (Item String) -- ^ Resulting item loadAndApplyTemplate identifier context item = do tpl <- loadBody identifier applyTemplate tpl context item -------------------------------------------------------------------------------- -- | It is also possible that you want to substitute @$key$@s within the body of -- an item. This function does that by interpreting the item body as a template, -- and then applying it to itself. applyAsTemplate :: Context String -- ^ Context -> Item String -- ^ Item and template -> Compiler (Item String) -- ^ Resulting item applyAsTemplate context item = let tpl = readTemplate $ itemBody item in applyTemplate tpl context item hakyll-4.4.3.0/src/Hakyll/Web/Html/0000755000000000000000000000000012261555376015002 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Web/Html/RelativizeUrls.hs0000644000000000000000000000374012261555376020326 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module exposes a function which can relativize URL's on a webpage. -- -- This means that one can deploy the resulting site on -- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@ -- without having to change anything (simply copy over the files). -- -- To use it, you should use absolute URL's from the site root everywhere. For -- example, use -- -- > Funny zomgroflcopter -- -- in a blogpost. When running this through the relativize URL's module, this -- will result in (suppose your blogpost is located at @\/posts\/foo.html@: -- -- > Funny zomgroflcopter module Hakyll.Web.Html.RelativizeUrls ( relativizeUrls , relativizeUrlsWith ) where -------------------------------------------------------------------------------- import Data.List (isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item import Hakyll.Web.Html -------------------------------------------------------------------------------- -- | Compiler form of 'relativizeUrls' which automatically picks the right root -- path relativizeUrls :: Item String -> Compiler (Item String) relativizeUrls item = do route <- getRoute $ itemIdentifier item return $ case route of Nothing -> item Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item -------------------------------------------------------------------------------- -- | Relativize URL's in HTML relativizeUrlsWith :: String -- ^ Path to the site root -> String -- ^ HTML to relativize -> String -- ^ Resulting HTML relativizeUrlsWith root = withUrls rel where isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x) rel x = if isRel x then root ++ x else x hakyll-4.4.3.0/src/Hakyll/Web/Pandoc/0000755000000000000000000000000012261555376015302 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Web/Pandoc/Biblio.hs0000644000000000000000000000707012261555376017042 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Wraps pandocs bibiliography handling -- -- In order to add a bibliography, you will need a bibliography file (e.g. -- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their -- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can -- refer to these files when you use 'pageReadPandocBiblio'. This function also -- takes the reader options for completeness -- you can use -- 'defaultHakyllReaderOptions' if you're unsure. {-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Web.Pandoc.Biblio ( CSL , cslCompiler , Biblio (..) , biblioCompiler , readPandocBiblio ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) import Data.Binary (Binary (..)) import Data.Typeable (Typeable) import qualified Text.CSL as CSL import Text.CSL.Pandoc (processCites) import Text.Pandoc (Pandoc, ReaderOptions (..)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Writable import Hakyll.Web.Pandoc -------------------------------------------------------------------------------- data CSL = CSL deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Binary CSL where put CSL = return () get = return CSL -------------------------------------------------------------------------------- instance Writable CSL where -- Shouldn't be written. write _ _ = return () -------------------------------------------------------------------------------- cslCompiler :: Compiler (Item CSL) cslCompiler = makeItem CSL -------------------------------------------------------------------------------- newtype Biblio = Biblio [CSL.Reference] deriving (Show, Typeable) -------------------------------------------------------------------------------- instance Binary Biblio where -- Ugly. get = Biblio . read <$> get put (Biblio rs) = put $ show rs -------------------------------------------------------------------------------- instance Writable Biblio where -- Shouldn't be written. write _ _ = return () -------------------------------------------------------------------------------- biblioCompiler :: Compiler (Item Biblio) biblioCompiler = do filePath <- toFilePath <$> getUnderlying makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath) -------------------------------------------------------------------------------- readPandocBiblio :: ReaderOptions -> Item CSL -> Item Biblio -> (Item String) -> Compiler (Item Pandoc) readPandocBiblio ropt csl biblio item = do -- Parse CSL file, if given style <- unsafeCompiler $ CSL.readCSLFile . toFilePath . itemIdentifier $ csl -- We need to know the citation keys, add then *before* actually parsing the -- actual page. If we don't do this, pandoc won't even consider them -- citations! let Biblio refs = itemBody biblio pandoc = itemBody $ readPandocWith ropt item pandoc' = processCites style refs pandoc return $ fmap (const pandoc') item hakyll-4.4.3.0/src/Hakyll/Web/Pandoc/FileType.hs0000644000000000000000000000447412261555376017370 0ustar0000000000000000-------------------------------------------------------------------------------- -- | A module dealing with pandoc file extensions and associated file types module Hakyll.Web.Pandoc.FileType ( FileType (..) , fileType , itemFileType ) where -------------------------------------------------------------------------------- import System.FilePath (splitExtension) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Item -------------------------------------------------------------------------------- -- | Datatype to represent the different file types Hakyll can deal with by -- default data FileType = Binary | Css | Html | LaTeX | LiterateHaskell FileType | Markdown | OrgMode | PlainText | Rst | Textile deriving (Eq, Ord, Show, Read) -------------------------------------------------------------------------------- -- | Get the file type for a certain file. The type is determined by extension. fileType :: FilePath -> FileType fileType = uncurry fileType' . splitExtension where fileType' _ ".css" = Css fileType' _ ".htm" = Html fileType' _ ".html" = Html fileType' f ".lhs" = LiterateHaskell $ case fileType f of -- If no extension is given, default to Markdown + LiterateHaskell Binary -> Markdown -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified x -> x fileType' _ ".markdown" = Markdown fileType' _ ".md" = Markdown fileType' _ ".mdn" = Markdown fileType' _ ".mdown" = Markdown fileType' _ ".mdwn" = Markdown fileType' _ ".mkd" = Markdown fileType' _ ".mkdwn" = Markdown fileType' _ ".org" = OrgMode fileType' _ ".page" = Markdown fileType' _ ".rst" = Rst fileType' _ ".tex" = LaTeX fileType' _ ".text" = PlainText fileType' _ ".textile" = Textile fileType' _ ".txt" = PlainText fileType' _ _ = Binary -- Treat unknown files as binary -------------------------------------------------------------------------------- -- | Get the file type for the current file itemFileType :: Item a -> FileType itemFileType = fileType . toFilePath . itemIdentifier hakyll-4.4.3.0/src/Hakyll/Web/Template/0000755000000000000000000000000012261555376015651 5ustar0000000000000000hakyll-4.4.3.0/src/Hakyll/Web/Template/Context.hs0000644000000000000000000002407712261555376017643 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE ExistentialQuantification #-} module Hakyll.Web.Template.Context ( ContextField (..) , Context (..) , field , constField , listField , functionField , mapContext , defaultContext , bodyField , metadataField , urlField , pathField , titleField , dateField , dateFieldWith , getItemUTC , modificationTimeField , modificationTimeFieldWith , teaserField , missingField ) where -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..), (<$>)) import Control.Monad (msum) import Data.List (intercalate) import qualified Data.Map as M import Data.Monoid (Monoid (..)) import Data.Time.Clock (UTCTime (..)) import Data.Time.Format (formatTime, parseTime) import System.FilePath (takeBaseName, takeFileName) import System.Locale (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 (splitAll, needlePrefix) import Hakyll.Web.Html -------------------------------------------------------------------------------- -- | Mostly for internal usage data ContextField = StringField String | forall a. ListField (Context a) [Item a] -------------------------------------------------------------------------------- newtype Context a = Context { unContext :: String -> Item a -> Compiler ContextField } -------------------------------------------------------------------------------- instance Monoid (Context a) where mempty = missingField mappend (Context f) (Context g) = Context $ \k i -> f k i <|> g k i -------------------------------------------------------------------------------- field' :: String -> (Item a -> Compiler ContextField) -> Context a field' key value = Context $ \k i -> if k == key then value i else empty -------------------------------------------------------------------------------- field :: String -> (Item a -> Compiler String) -> Context a field key value = field' key (fmap StringField . value) -------------------------------------------------------------------------------- constField :: String -> String -> Context a constField key = field key . const . return -------------------------------------------------------------------------------- listField :: String -> Context a -> Compiler [Item a] -> Context b listField key c xs = field' key $ \_ -> fmap (ListField c) xs -------------------------------------------------------------------------------- functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a functionField name value = Context $ \k i -> case words k of [] -> empty (n : args) | n == name -> StringField <$> value args i | otherwise -> empty -------------------------------------------------------------------------------- mapContext :: (String -> String) -> Context a -> Context a mapContext f (Context c) = Context $ \k i -> do fld <- c k i case fld of StringField str -> return $ StringField (f str) ListField _ _ -> fail $ "Hakyll.Web.Template.Context.mapContext: " ++ "can't map over a ListField!" -------------------------------------------------------------------------------- defaultContext :: Context String defaultContext = bodyField "body" `mappend` metadataField `mappend` urlField "url" `mappend` pathField "path" `mappend` titleField "title" `mappend` missingField -------------------------------------------------------------------------------- teaserSeparator :: String teaserSeparator = "" -------------------------------------------------------------------------------- bodyField :: String -> Context String bodyField key = field key $ return . itemBody -------------------------------------------------------------------------------- -- | Map any field to its metadata value, if present metadataField :: Context a metadataField = Context $ \k i -> do value <- getMetadataField (itemIdentifier i) k maybe empty (return . StringField) value -------------------------------------------------------------------------------- -- | Absolute url to the resulting item urlField :: String -> Context a urlField key = field key $ fmap (maybe empty toUrl) . getRoute . itemIdentifier -------------------------------------------------------------------------------- -- | Filepath of the underlying file of the item pathField :: String -> Context a pathField key = field key $ return . toFilePath . itemIdentifier -------------------------------------------------------------------------------- -- | This title field takes the basename of the underlying file by default titleField :: String -> Context a titleField = mapContext takeBaseName . pathField -------------------------------------------------------------------------------- -- | When the metadata has a field called @published@ in one of the -- following formats then this function can render the date. -- -- * @Mon, 06 Sep 2010 00:01:00 +0000@ -- -- * @Mon, 06 Sep 2010 00:01:00 UTC@ -- -- * @Mon, 06 Sep 2010 00:01:00@ -- -- * @2010-09-06T00:01:00+0000@ -- -- * @2010-09-06T00:01:00Z@ -- -- * @2010-09-06T00:01:00@ -- -- * @2010-09-06 00:01:00+0000@ -- -- * @2010-09-06 00:01:00@ -- -- * @September 06, 2010 00:01 AM@ -- -- Following date-only formats are supported too (@00:00:00@ for time is -- assumed) -- -- * @2010-09-06@ -- -- * @September 06, 2010@ -- -- Alternatively, when the metadata has a field called @path@ in a -- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages) -- and no @published@ metadata field set, this function can render -- the date. dateField :: String -- ^ Key in which the rendered date should be placed -> String -- ^ Format to use on the date -> Context a -- ^ Resulting context dateField = dateFieldWith defaultTimeLocale -------------------------------------------------------------------------------- -- | This is an extended version of 'dateField' that allows you to -- specify a time locale that is used for outputting the date. For more -- details, see 'dateField'. dateFieldWith :: TimeLocale -- ^ Output time locale -> String -- ^ Destination key -> String -- ^ Format to use on the date -> Context a -- ^ Resulting context dateFieldWith locale key format = field key $ \i -> do time <- getItemUTC locale $ itemIdentifier i return $ formatTime locale format time -------------------------------------------------------------------------------- -- | Parser to try to extract and parse the time from the @published@ -- field or from the filename. See 'dateField' for more information. -- Exported for user convenience. getItemUTC :: MonadMetadata m => TimeLocale -- ^ Output time locale -> Identifier -- ^ Input page -> m UTCTime -- ^ Parsed UTCTime getItemUTC locale id' = do metadata <- getMetadata id' let tryField k fmt = M.lookup k metadata >>= parseTime' fmt fn = takeFileName $ toFilePath id' maybe empty' return $ msum $ [tryField "published" fmt | fmt <- formats] ++ [tryField "date" fmt | fmt <- formats] ++ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fn] where empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++ "could not parse time for " ++ show id' parseTime' = parseTime locale formats = [ "%a, %d %b %Y %H:%M:%S %Z" , "%Y-%m-%dT%H:%M:%S%Z" , "%Y-%m-%d %H:%M:%S%Z" , "%Y-%m-%d" , "%B %e, %Y %l:%M %p" , "%B %e, %Y" , "%b %d, %Y" ] -------------------------------------------------------------------------------- modificationTimeField :: String -- ^ Key -> String -- ^ Format -> Context a -- ^ Resuting context modificationTimeField = modificationTimeFieldWith defaultTimeLocale -------------------------------------------------------------------------------- modificationTimeFieldWith :: TimeLocale -- ^ Time output locale -> String -- ^ Key -> String -- ^ Format -> Context a -- ^ Resulting context modificationTimeFieldWith locale key fmt = field key $ \i -> do provider <- compilerProvider <$> compilerAsk let mtime = resourceModificationTime provider $ itemIdentifier i return $ formatTime locale fmt mtime -------------------------------------------------------------------------------- -- | A context with "teaser" key which contain a teaser of the item. -- The item is loaded from the given snapshot (which should be saved -- in the user code before any templates are applied). teaserField :: String -- ^ Key to use -> Snapshot -- ^ Snapshot to load -> Context String -- ^ Resulting context teaserField key snapshot = field key $ \item -> do body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot case needlePrefix teaserSeparator body of Nothing -> fail $ "Hakyll.Web.Template.Context: no teaser defined for " ++ show (itemIdentifier item) Just t -> return t -------------------------------------------------------------------------------- missingField :: Context a missingField = Context $ \k i -> fail $ "Missing field $" ++ k ++ "$ in context for item " ++ show (itemIdentifier i) hakyll-4.4.3.0/src/Hakyll/Web/Template/Internal.hs0000644000000000000000000000437612261555376017773 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Module containing the template data structure {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Web.Template.Internal ( Template (..) , TemplateElement (..) ) where -------------------------------------------------------------------------------- import Control.Applicative (pure, (<$>), (<*>)) import Data.Binary (Binary, get, getWord8, put, putWord8) import Data.Typeable (Typeable) -------------------------------------------------------------------------------- import Hakyll.Core.Writable -------------------------------------------------------------------------------- -- | Datatype used for template substitutions. newtype Template = Template { unTemplate :: [TemplateElement] } deriving (Show, Eq, Binary, Typeable) -------------------------------------------------------------------------------- instance Writable Template where -- Writing a template is impossible write _ _ = return () -------------------------------------------------------------------------------- -- | Elements of a template. data TemplateElement = Chunk String | Key String | Escaped | If String Template (Maybe Template) -- key, then branch, else branch | For String Template (Maybe Template) -- key, body, separator | Partial String -- filename deriving (Show, Eq, Typeable) -------------------------------------------------------------------------------- instance Binary TemplateElement where put (Chunk string) = putWord8 0 >> put string put (Key key) = putWord8 1 >> put key put (Escaped) = putWord8 2 put (If key t f) = putWord8 3 >> put key >> put t >> put f put (For key b s) = putWord8 4 >> put key >> put b >> put s put (Partial p) = putWord8 5 >> put p get = getWord8 >>= \tag -> case tag of 0 -> Chunk <$> get 1 -> Key <$> get 2 -> pure Escaped 3 -> If <$> get <*> get <*> get 4 -> For <$> get <*> get <*> get 5 -> Partial <$> get _ -> error $ "Hakyll.Web.Template.Internal: Error reading cached template" hakyll-4.4.3.0/src/Hakyll/Web/Template/List.hs0000644000000000000000000000510612261555376017122 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Provides an easy way to combine several items in a list. The applications -- are obvious: -- -- * A post list on a blog -- -- * An image list in a gallery -- -- * A sitemap {-# LANGUAGE TupleSections #-} module Hakyll.Web.Template.List ( applyTemplateList , applyJoinTemplateList , chronological , recentFirst ) where -------------------------------------------------------------------------------- import Control.Monad (liftM) import Data.List (intersperse, sortBy) import Data.Ord (comparing) import System.Locale (defaultTimeLocale) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Web.Template import Hakyll.Web.Template.Context -------------------------------------------------------------------------------- -- | Generate a string of a listing of pages, after applying a template to each -- page. applyTemplateList :: Template -> Context a -> [Item a] -> Compiler String applyTemplateList = applyJoinTemplateList "" -------------------------------------------------------------------------------- -- | Join a listing of pages with a string in between, after applying a template -- to each page. applyJoinTemplateList :: String -> Template -> Context a -> [Item a] -> Compiler String applyJoinTemplateList delimiter tpl context items = do items' <- mapM (applyTemplate tpl context) items return $ concat $ intersperse delimiter $ map itemBody items' -------------------------------------------------------------------------------- -- | Sort pages chronologically. Uses the same method as 'dateField' for -- extracting the date. chronological :: MonadMetadata m => [Item a] -> m [Item a] chronological = sortByM $ getItemUTC defaultTimeLocale . itemIdentifier where sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a] sortByM f xs = liftM (map fst . sortBy (comparing snd)) $ mapM (\x -> liftM (x,) (f x)) xs -------------------------------------------------------------------------------- -- | The reverse of 'chronological' recentFirst :: (MonadMetadata m, Functor m) => [Item a] -> m [Item a] recentFirst = fmap reverse . chronological hakyll-4.4.3.0/src/Hakyll/Web/Template/Read.hs0000644000000000000000000000541712261555376017067 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Read templates in Hakyll's native format module Hakyll.Web.Template.Read ( readTemplate ) where -------------------------------------------------------------------------------- import Control.Applicative ((<$), (<$>)) import Control.Monad (void) import Text.Parsec import Text.Parsec.String -------------------------------------------------------------------------------- import Hakyll.Core.Util.Parser import Hakyll.Web.Template.Internal -------------------------------------------------------------------------------- readTemplate :: String -> Template readTemplate input = case parse template "" input of Left err -> error $ "Cannot parse template: " ++ show err Right t -> t -------------------------------------------------------------------------------- template :: Parser Template template = Template <$> (many1 $ chunk <|> escaped <|> conditional <|> for <|> partial <|> key) -------------------------------------------------------------------------------- chunk :: Parser TemplateElement chunk = Chunk <$> (many1 $ noneOf "$") -------------------------------------------------------------------------------- escaped :: Parser TemplateElement escaped = Escaped <$ (try $ string "$$") -------------------------------------------------------------------------------- conditional :: Parser TemplateElement conditional = try $ do void $ string "$if(" i <- metadataKey void $ string ")$" thenBranch <- template elseBranch <- optionMaybe $ try (string "$else$") >> template void $ string "$endif$" return $ If i thenBranch elseBranch -------------------------------------------------------------------------------- for :: Parser TemplateElement for = try $ do void $ string "$for(" i <- metadataKey void $ string ")$" body <- template sep <- optionMaybe $ try (string "$sep$") >> template void $ string "$endfor$" return $ For i body sep -------------------------------------------------------------------------------- partial :: Parser TemplateElement partial = try $ do void $ string "$partial(" i <- stringLiteral void $ string ")$" return $ Partial i -------------------------------------------------------------------------------- key :: Parser TemplateElement key = try $ do void $ char '$' k <- metadataKey void $ char '$' return $ Key k -------------------------------------------------------------------------------- stringLiteral :: Parser String stringLiteral = do void $ char '\"' str <- many $ do x <- noneOf "\"" if x == '\\' then anyChar else return x void $ char '\"' return str hakyll-4.4.3.0/tests/0000755000000000000000000000000012261555376012510 5ustar0000000000000000hakyll-4.4.3.0/tests/TestSuite.hs0000644000000000000000000000335512261555376015003 0ustar0000000000000000-------------------------------------------------------------------------------- module Main ( main ) where -------------------------------------------------------------------------------- import Test.Framework (defaultMain) -------------------------------------------------------------------------------- import qualified Hakyll.Core.Dependencies.Tests import qualified Hakyll.Core.Identifier.Tests import qualified Hakyll.Core.Provider.Metadata.Tests import qualified Hakyll.Core.Provider.Tests import qualified Hakyll.Core.Routes.Tests import qualified Hakyll.Core.Rules.Tests import qualified Hakyll.Core.Runtime.Tests import qualified Hakyll.Core.Store.Tests import qualified Hakyll.Core.UnixFilter.Tests import qualified Hakyll.Core.Util.String.Tests import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests import qualified Hakyll.Web.Pandoc.FileType.Tests import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ Hakyll.Core.Dependencies.Tests.tests , Hakyll.Core.Identifier.Tests.tests , Hakyll.Core.Provider.Metadata.Tests.tests , Hakyll.Core.Provider.Tests.tests , Hakyll.Core.Routes.Tests.tests , Hakyll.Core.Rules.Tests.tests , Hakyll.Core.Runtime.Tests.tests , Hakyll.Core.Store.Tests.tests , Hakyll.Core.UnixFilter.Tests.tests , Hakyll.Core.Util.String.Tests.tests , Hakyll.Web.Html.RelativizeUrls.Tests.tests , Hakyll.Web.Html.Tests.tests , Hakyll.Web.Pandoc.FileType.Tests.tests , Hakyll.Web.Template.Context.Tests.tests , Hakyll.Web.Template.Tests.tests ] hakyll-4.4.3.0/tests/data/0000755000000000000000000000000012261555376013421 5ustar0000000000000000hakyll-4.4.3.0/tests/data/example.md0000644000000000000000000000005712261555376015400 0ustar0000000000000000--- title: An example --- This is an example. hakyll-4.4.3.0/tests/data/example.md.metadata0000644000000000000000000000010012261555376017144 0ustar0000000000000000external: External data date: 2012-10-22 14:35:24 subblog: food hakyll-4.4.3.0/tests/data/russian.md0000644000000000000000000000214012261555376015424 0ustar0000000000000000Статья 18 Каждый человек имеет право на свободу мысли, совести и религии; это право включает свободу менять свою религию или убеждения и свободу исповедовать свою религию или убеждения как единолично, так и сообща с другими, публичным или частным порядком в учении, богослужении и выполнении религиозных и ритуальных обрядов. Статья 19 Каждый человек имеет право на свободу убеждений и на свободное выражение их; это право включает свободу беспрепятственно придерживаться своих убеждений и свободу искать, получать и распространять информацию и идеи любыми средствами и независимо от государственных границ. hakyll-4.4.3.0/tests/data/template.html0000644000000000000000000000054512261555376016126 0ustar0000000000000000
I'm so rich I have $$3. $rev foo$ $if(body)$ I have body $else$ or no $endif$ $if(unbound)$ should not be printed $endif$ $if(body)$ should be printed $endif$
    $for(authors)$
  • $name$
    • $endfor$
$for(authors)$$name$$sep$, $endfor$ $body$
hakyll-4.4.3.0/tests/data/template.html.out0000644000000000000000000000036012261555376016727 0ustar0000000000000000
I'm so rich I have $3. oof I have body should be printed
  • Jan
  • Piet
Jan, Piet

This is an example.

hakyll-4.4.3.0/tests/data/images/0000755000000000000000000000000012261555376014666 5ustar0000000000000000hakyll-4.4.3.0/tests/data/images/favicon.ico0000644000000000000000000000217612261555376017015 0ustar0000000000000000 h(  ?~~~~~~~~?>>>>>>>>>>>>>>>MMMNNNFFFQQQ>>>??~~~~ ~~~~!!!{{{\\\<<<VVV(((~~~~~~~~?$$$ooo?>>>???>>>>>>???ttt(((>>>>>>>>>?~~~~~~~~???hakyll-4.4.3.0/tests/data/posts/0000755000000000000000000000000012261555376014571 5ustar0000000000000000hakyll-4.4.3.0/tests/data/posts/2010-08-26-birthday.md0000644000000000000000000000003012261555376017744 0ustar0000000000000000It's my birthday today. hakyll-4.4.3.0/tests/Hakyll/0000755000000000000000000000000012261555376013734 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/0000755000000000000000000000000012261555376014624 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Dependencies/0000755000000000000000000000000012261555376017212 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Dependencies/Tests.hs0000644000000000000000000000431712261555376020655 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Dependencies.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.List (delete) import qualified Data.Map as M import qualified Data.Set as S import Test.Framework (Test, testGroup) import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Dependencies.Tests" $ fromAssertions "analyze" [case01, case02, case03] -------------------------------------------------------------------------------- oldUniverse :: [Identifier] oldUniverse = M.keys oldFacts -------------------------------------------------------------------------------- oldFacts :: DependencyFacts oldFacts = M.fromList [ ("posts/01.md", []) , ("posts/02.md", []) , ("index.md", [ PatternDependency "posts/*" ["posts/01.md", "posts/02.md"] , IdentifierDependency "posts/01.md" , IdentifierDependency "posts/02.md" ]) ] -------------------------------------------------------------------------------- -- | posts/02.md has changed case01 :: Assertion case01 = S.fromList ["posts/02.md", "index.md"] @=? ood where (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts -------------------------------------------------------------------------------- -- | about.md was added case02 :: Assertion case02 = S.singleton "about.md" @=? ood where (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts -------------------------------------------------------------------------------- -- | posts/01.md was removed case03 :: Assertion case03 = S.singleton "index.md" @=? ood where (ood, _, _) = outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts hakyll-4.4.3.0/tests/Hakyll/Core/Identifier/0000755000000000000000000000000012261555376016706 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Identifier/Tests.hs0000644000000000000000000000515512261555376020352 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Identifier.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.HUnit ((@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests ] -------------------------------------------------------------------------------- captureTests :: [Test] 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" ] -------------------------------------------------------------------------------- matchesTests :: [Test] matchesTests = fromAssertions "matches" [ True @=? matches (fromList ["foo.markdown"]) "foo.markdown" , False @=? matches (fromList ["foo"]) (setVersion (Just "x") "foo") , True @=? matches (fromVersion (Just "xz")) (setVersion (Just "xz") "bar") , True @=? matches (fromRegex "^foo/[^x]*$") "foo/bar" , False @=? matches (fromRegex "^foo/[^x]*$") "foo/barx" , True @=? matches (complement "foo.markdown") "bar.markdown" , False @=? matches (complement "foo.markdown") "foo.markdown" , True @=? matches ("foo" .||. "bar") "bar" , False @=? matches ("bar" .&&. hasNoVersion) (setVersion (Just "xz") "bar") ] hakyll-4.4.3.0/tests/Hakyll/Core/Provider/0000755000000000000000000000000012261555376016416 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Provider/Tests.hs0000644000000000000000000000251412261555376020056 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Provider.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Map as M import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assert, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Provider import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Provider.Tests" [ testCase "case01" case01 ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do store <- newTestStore provider <- newTestProvider store assert $ resourceExists provider "example.md" metadata <- resourceMetadata provider "example.md" Just "An example" @=? M.lookup "title" metadata Just "External data" @=? M.lookup "external" metadata doesntExist <- resourceMetadata provider "doesntexist.md" M.empty @=? doesntExist cleanTestEnv hakyll-4.4.3.0/tests/Hakyll/Core/Provider/Metadata/0000755000000000000000000000000012261555376020136 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Provider/Metadata/Tests.hs0000644000000000000000000000345312261555376021601 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Provider.Metadata.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.HUnit (Assertion, (@=?)) import Text.Parsec as P import Text.Parsec.String (Parser) -------------------------------------------------------------------------------- import Hakyll.Core.Provider.Metadata import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Provider.Metadata.Tests" $ fromAssertions "page" [testPage01, testPage02] -------------------------------------------------------------------------------- testPage01 :: Assertion testPage01 = testParse page ([("foo", "bar")], "qux\n") "---\n\ \foo: bar\n\ \---\n\ \qux\n" -------------------------------------------------------------------------------- testPage02 :: Assertion testPage02 = testParse page ([("description", descr)], "Hello I am dog\n") "---\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" where descr = "A long description that would look better if it \ \spanned multiple lines and was indented" -------------------------------------------------------------------------------- testParse :: (Eq a, Show a) => Parser a -> a -> String -> Assertion testParse parser expected input = case P.parse parser "" input of Left err -> error $ show err Right x -> expected @=? x hakyll-4.4.3.0/tests/Hakyll/Core/Routes/0000755000000000000000000000000012261555376016105 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Routes/Tests.hs0000644000000000000000000000362412261555376017550 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Routes.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Map as M import System.FilePath (()) import Test.Framework (Test, testGroup) import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Routes import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes" [ testRoutes "foo.html" (setExtension "html") "foo" , testRoutes "foo.html" (setExtension ".html") "foo" , testRoutes "foo.html" (setExtension "html") "foo.markdown" , testRoutes "foo.html" (setExtension ".html") "foo.markdown" , testRoutes "neve ro ddo reven" (customRoute (reverse . toFilePath )) "never odd or even" , testRoutes "foo" (constRoute "foo") "bar" , testRoutes "tags/bar.xml" (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" , testRoutes "tags/bar.xml" (gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml") "tags/rss/bar" , testRoutes "food/example.md" (metadataRoute $ \md -> customRoute $ \id' -> M.findWithDefault "?" "subblog" md toFilePath id') "example.md" ] -------------------------------------------------------------------------------- testRoutes :: FilePath -> Routes -> Identifier -> Assertion testRoutes expected r id' = do store <- newTestStore provider <- newTestProvider store (route, _) <- runRoutes r provider id' Just expected @=? route cleanTestEnv hakyll-4.4.3.0/tests/Hakyll/Core/Rules/0000755000000000000000000000000012261555376015716 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Rules/Tests.hs0000644000000000000000000000620012261555376017352 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Set as S import Test.Framework (Test, testGroup) import Test.HUnit (Assertion, assert, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.File import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal import Hakyll.Web.Pandoc import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Rules.Tests" $ fromAssertions "runRules" [case01] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do ioref <- newIORef False store <- newTestStore provider <- newTestProvider store ruleSet <- runRules (rules01 ioref) provider let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet routes = rulesRoutes ruleSet checkRoute ex i = runRoutes routes provider i >>= \(r, _) -> Just ex @=? r -- Test that we have some identifiers and that the routes work out assert $ all (`S.member` identifiers) expected checkRoute "example.html" "example.md" checkRoute "example.md" (sv "raw" "example.md") checkRoute "example.md" (sv "nav" "example.md") checkRoute "example.mv1" (sv "mv1" "example.md") checkRoute "example.mv2" (sv "mv2" "example.md") readIORef ioref >>= assert cleanTestEnv where sv g = setVersion (Just g) expected = [ "example.md" , "russian.md" , sv "raw" "example.md" , sv "raw" "russian.md" , sv "nav" "example.md" ] -------------------------------------------------------------------------------- rules01 :: IORef Bool -> Rules () rules01 ioref = do -- Compile some posts match "*.md" $ do route $ setExtension "html" compile pandocCompiler -- Yeah. I don't know how else to test this stuff? preprocess $ writeIORef ioref True -- Compile them, raw match "*.md" $ version "raw" $ do route idRoute compile getResourceString -- Regression test version "nav" $ match (fromList ["example.md"]) $ do route idRoute compile copyFileCompiler -- Another edge case: different versions in one match match "*.md" $ do version "mv1" $ do route $ setExtension "mv1" compile getResourceString version "mv2" $ do route $ setExtension "mv2" compile getResourceString hakyll-4.4.3.0/tests/Hakyll/Core/Runtime/0000755000000000000000000000000012261555376016247 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Runtime/Tests.hs0000644000000000000000000000506312261555376017711 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Runtime.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.ByteString as B import System.FilePath (()) import Test.Framework (Test, testGroup) import Test.HUnit (Assertion, (@?=)) -------------------------------------------------------------------------------- import Hakyll import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Runtime import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run" [case01, case02] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do _ <- run testConfiguration Logger.Error $ do match "images/*" $ do route idRoute compile copyFileCompiler match "*.md" $ do route $ setExtension "html" compile $ do getResourceBody >>= saveSnapshot "raw" >>= return . renderPandoc create ["bodies.txt"] $ do route idRoute compile $ do items <- loadAllSnapshots "*.md" "raw" makeItem $ concat $ map itemBody (items :: [Item String]) favicon <- B.readFile $ providerDirectory testConfiguration "images/favicon.ico" favicon' <- B.readFile $ destinationDirectory testConfiguration "images/favicon.ico" favicon @?= favicon' example <- readFile $ destinationDirectory testConfiguration "example.html" lines example @?= ["

This is an example.

"] bodies <- readFile $ destinationDirectory testConfiguration "bodies.txt" head (lines bodies) @?= "This is an example." cleanTestEnv -------------------------------------------------------------------------------- case02 :: Assertion case02 = do _ <- run testConfiguration Logger.Error $ do match "images/favicon.ico" $ do route $ gsubRoute "images/" (const "") compile $ makeItem ("Test" :: String) match "images/**" $ do route idRoute compile copyFileCompiler favicon <- readFile $ destinationDirectory testConfiguration "favicon.ico" favicon @?= "Test" cleanTestEnv hakyll-4.4.3.0/tests/Hakyll/Core/Store/0000755000000000000000000000000012261555376015720 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Store/Tests.hs0000644000000000000000000000573712261555376017372 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Store.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.Typeable (typeOf) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import qualified Test.HUnit as H import qualified Test.QuickCheck as Q import qualified Test.QuickCheck.Monadic as Q -------------------------------------------------------------------------------- import qualified Hakyll.Core.Store as Store import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Store.Tests" [ testProperty "simple get . set" simpleSetGet , testProperty "persistent get . set" persistentSetGet , testCase "WrongType get . set" wrongType , testCase "isMembertest . set" isMembertest ] -------------------------------------------------------------------------------- simpleSetGet :: Q.Property simpleSetGet = Q.monadicIO $ do key <- Q.pick Q.arbitrary value <- Q.pick Q.arbitrary store <- Q.run newTestStore Q.run $ Store.set store key (value :: String) value' <- Q.run $ Store.get store key Q.assert $ Store.Found value == value' Q.run cleanTestEnv -------------------------------------------------------------------------------- persistentSetGet :: Q.Property persistentSetGet = Q.monadicIO $ do key <- Q.pick Q.arbitrary value <- Q.pick Q.arbitrary store1 <- Q.run newTestStore Q.run $ Store.set store1 key (value :: String) -- Now Create another store from the same dir to test persistence store2 <- Q.run newTestStore value' <- Q.run $ Store.get store2 key Q.assert $ Store.Found value == value' Q.run cleanTestEnv -------------------------------------------------------------------------------- wrongType :: H.Assertion wrongType = do store <- newTestStore -- 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 cleanTestEnv -------------------------------------------------------------------------------- isMembertest :: H.Assertion isMembertest = do store <- newTestStore 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) cleanTestEnv hakyll-4.4.3.0/tests/Hakyll/Core/UnixFilter/0000755000000000000000000000000012261555376016715 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/UnixFilter/Tests.hs0000644000000000000000000000401212261555376020350 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.UnixFilter.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.List (isInfixOf) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import qualified Test.HUnit as H -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Item import Hakyll.Core.UnixFilter import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.UnixFilter.Tests" [ testCase "unixFilter rev" unixFilterRev , testCase "unixFilter false" unixFilterFalse ] -------------------------------------------------------------------------------- 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) cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "rev" []) rev = map reverse . lines -------------------------------------------------------------------------------- unixFilterFalse :: H.Assertion 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 cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "false" []) hakyll-4.4.3.0/tests/Hakyll/Core/Util/0000755000000000000000000000000012261555376015541 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Util/String/0000755000000000000000000000000012261555376017007 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Core/Util/String/Tests.hs0000644000000000000000000000257212261555376020453 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Core.Util.String.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.HUnit ((@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Util.String import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Util.String.Tests" $ concat [ fromAssertions "trim" [ "foo" @=? trim " foo\n\t " ] , fromAssertions "replaceAll" [ "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83" ] , fromAssertions "splitAll" [ ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi" ] , fromAssertions "needlePrefix" [ Just "ab" @=? needlePrefix "cd" "abcde" , Just "xx" @=? needlePrefix "ab" "xxab" , Nothing @=? needlePrefix "a" "xx" , Just "x" @=? needlePrefix "ab" "xabxab" , Just "" @=? needlePrefix "ab" "abc" , Just "" @=? needlePrefix "ab" "abab" , Nothing @=? needlePrefix "" "" ] ] where readInt :: String -> Int readInt = read hakyll-4.4.3.0/tests/Hakyll/Web/0000755000000000000000000000000012261555376014451 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Html/0000755000000000000000000000000012261555376015355 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Html/Tests.hs0000644000000000000000000000577512261555376017031 0ustar0000000000000000-------------------------------------------------------------------------------- module Hakyll.Web.Html.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.Char (toUpper) import Test.Framework (Test, testGroup) import Test.HUnit (assert, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Web.Html import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "

A h1 title

" @=? demoteHeaders "

A h1 title

" ] , fromAssertions "withUrls" [ "bar" @=? withUrls (map toUpper) "bar" , "" @=? withUrls (map toUpper) "" -- Test escaping , "" @=? withUrls id "" , "<stdio>" @=? withUrls id "<stdio>" , "" @=? withUrls id "" -- Test minimizing elements , "" @=? withUrls id "" ] , fromAssertions "toUrl" [ "/foo/bar.html" @=? toUrl "foo/bar.html" , "/" @=? toUrl "/" , "/funny-pics.html" @=? toUrl "/funny-pics.html" , "/funny%20pics.html" @=? toUrl "funny pics.html" -- Test various reserved characters (RFC 3986, section 2.2) , "/%21%2A%27%28%29%3B%3A%40%26.html" @=? toUrl "/!*'();:@&.html" , "/%3D%2B%24%2C/%3F%23%5B%5D.html" @=? toUrl "=+$,/?#[].html" -- Test various characters that are nor reserved, nor unreserved. , "/%E3%81%82%F0%9D%90%87%E2%88%80" @=? toUrl "\12354\119815\8704" ] , fromAssertions "toSiteRoot" [ ".." @=? toSiteRoot "/foo/bar.html" , "." @=? toSiteRoot "index.html" , "." @=? toSiteRoot "/index.html" , "../.." @=? toSiteRoot "foo/bar/qux" ] , 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")) ] , fromAssertions "stripTags" [ "foo" @=? stripTags "

foo

" , "foo bar" @=? stripTags "

foo

bar" , "foo" @=? stripTags "

foo" ] ] hakyll-4.4.3.0/tests/Hakyll/Web/Html/RelativizeUrls/0000755000000000000000000000000012261555376020341 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs0000644000000000000000000000274212261555376022004 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Html.RelativizeUrls.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.HUnit ((@=?)) -------------------------------------------------------------------------------- import Hakyll.Web.Html.RelativizeUrls import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Web.Html.RelativizeUrls.Tests" $ fromAssertions "relativizeUrls" [ "bar" @=? relativizeUrlsWith ".." "bar" , "" @=? relativizeUrlsWith "../.." "" , "Haskell" @=? relativizeUrlsWith "../.." "Haskell" , "Haskell" @=? relativizeUrlsWith "../.." "Haskell" , "" @=? relativizeUrlsWith "../.." "" ] hakyll-4.4.3.0/tests/Hakyll/Web/Pandoc/0000755000000000000000000000000012261555376015655 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Pandoc/FileType/0000755000000000000000000000000012261555376017376 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Pandoc/FileType/Tests.hs0000644000000000000000000000174712261555376021045 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Pandoc.FileType.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.HUnit ((@=?)) -------------------------------------------------------------------------------- import Hakyll.Web.Pandoc.FileType import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $ fromAssertions "fileType" [ Markdown @=? fileType "index.md" , Rst @=? fileType "about/foo.rst" , LiterateHaskell Markdown @=? fileType "posts/bananas.lhs" , LiterateHaskell LaTeX @=? fileType "posts/bananas.tex.lhs" ] hakyll-4.4.3.0/tests/Hakyll/Web/Template/0000755000000000000000000000000012261555376016224 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Template/Tests.hs0000644000000000000000000000513012261555376017661 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Template.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.Monoid (mconcat) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?), (@?=)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler 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 import Hakyll.Web.Template.List import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Template.Tests" [ testCase "case01" case01 , testCase "applyJoinTemplateList" testApplyJoinTemplateList ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do store <- newTestStore provider <- newTestProvider store out <- resourceString provider "template.html.out" tpl <- testCompilerDone store provider "template.html" $ templateCompiler item <- testCompilerDone store provider "example.md" $ pandocCompiler >>= applyTemplate (itemBody tpl) testContext writeFile "foo" (itemBody item) out @=? itemBody item cleanTestEnv -------------------------------------------------------------------------------- testContext :: Context String testContext = mconcat [ defaultContext , listField "authors" (bodyField "name") $ do n1 <- makeItem "Jan" n2 <- makeItem "Piet" return [n1, n2] , functionField "rev" $ \args _ -> return $ unwords $ map reverse args ] where -------------------------------------------------------------------------------- testApplyJoinTemplateList :: Assertion testApplyJoinTemplateList = do store <- newTestStore provider <- newTestProvider store str <- testCompilerDone store provider "item3" $ applyJoinTemplateList ", " tpl defaultContext [i1, i2] str @?= "Hello, World" cleanTestEnv where i1 = Item "item1" "Hello" i2 = Item "item2" "World" tpl = Template [Chunk "", Key "body", Chunk ""] hakyll-4.4.3.0/tests/Hakyll/Web/Template/Context/0000755000000000000000000000000012261555376017650 5ustar0000000000000000hakyll-4.4.3.0/tests/Hakyll/Web/Template/Context/Tests.hs0000644000000000000000000000406112261555376021307 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Template.Context.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Provider import Hakyll.Core.Store (Store) import Hakyll.Web.Template.Context import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Template.Context.Tests" [ testCase "testDateField" testDateField ] -------------------------------------------------------------------------------- testDateField :: Assertion testDateField = do store <- newTestStore provider <- newTestProvider store date1 <- testContextDone store provider "example.md" "date" $ dateField "date" "%B %e, %Y" date1 @=? "October 22, 2012" date2 <- testContextDone store provider "posts/2010-08-26-birthday.md" "date" $ dateField "date" "%B %e, %Y" date2 @=? "August 26, 2010" cleanTestEnv -------------------------------------------------------------------------------- testContextDone :: Store -> Provider -> Identifier -> String -> Context String -> IO String testContextDone store provider identifier key context = testCompilerDone store provider identifier $ do item <- getResourceBody cf <- unContext context key item case cf of StringField str -> return str ListField _ _ -> error $ "Hakyll.Web.Template.Context.Tests.testContextDone: " ++ "Didn't expect ListField" hakyll-4.4.3.0/tests/TestSuite/0000755000000000000000000000000012261555376014441 5ustar0000000000000000hakyll-4.4.3.0/tests/TestSuite/Util.hs0000644000000000000000000000746512261555376015726 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Test utilities module TestSuite.Util ( fromAssertions , newTestStore , newTestProvider , testCompiler , testCompilerDone , testConfiguration , cleanTestEnv ) where -------------------------------------------------------------------------------- import Data.List (intercalate) import Data.Monoid (mempty) import qualified Data.Set as S import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Text.Printf (printf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler.Internal import Hakyll.Core.Configuration import Hakyll.Core.Identifier import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Provider import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File -------------------------------------------------------------------------------- fromAssertions :: String -- ^ Name -> [Assertion] -- ^ Cases -> [Test] -- ^ Result tests fromAssertions name = zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]] -------------------------------------------------------------------------------- newTestStore :: IO Store newTestStore = Store.new True $ storeDirectory testConfiguration -------------------------------------------------------------------------------- newTestProvider :: Store -> IO Provider newTestProvider store = newProvider store (const $ return False) $ providerDirectory testConfiguration -------------------------------------------------------------------------------- testCompiler :: Store -> Provider -> Identifier -> Compiler a -> IO (CompilerResult a) testCompiler store provider underlying compiler = do logger <- Logger.new Logger.Error let read' = CompilerRead { compilerConfig = testConfiguration , compilerUnderlying = underlying , compilerProvider = provider , compilerUniverse = S.empty , compilerRoutes = mempty , compilerStore = store , compilerLogger = logger } result <- runCompiler compiler read' Logger.flush logger return result -------------------------------------------------------------------------------- testCompilerDone :: Store -> Provider -> Identifier -> Compiler a -> IO a testCompilerDone store provider underlying compiler = do result <- testCompiler store provider underlying compiler case result of CompilerDone x _ -> return x CompilerError e -> error $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++ " threw: " ++ intercalate "; " e CompilerRequire i _ -> error $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++ " requires: " ++ show i -------------------------------------------------------------------------------- testConfiguration :: Configuration testConfiguration = defaultConfiguration { destinationDirectory = "_testsite" , storeDirectory = "_teststore" , tmpDirectory = "_testtmp" , providerDirectory = "tests/data" } -------------------------------------------------------------------------------- cleanTestEnv :: IO () cleanTestEnv = do removeDirectory $ destinationDirectory testConfiguration removeDirectory $ storeDirectory testConfiguration removeDirectory $ tmpDirectory testConfiguration