diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,46 @@ # Releases +## Hakyll 4.14.1.0 (2021-08-30) + +- Add `Hakyll.Web.Html.demoteHeaderBy` function, which demotes an HTML header by + a given amount (contribution by Logan McGrath) +- Add `Hakyll.Core.Rules.forceCompile` modifier which forces re-compilation of + an item even if its file wasn't modified. This is useful for data sources + which aren't local files (contribution by Fraser Tweedale) +- Add `Hakyll.Web.Tags.getTagsByField` which extracts tags from a given field + instead of the default "tags" field (contribution by Jim McStanton and + Alexander Batischev) +- Add `Hakyll.Core.Configuration.shouldWatchIgnore` function and the + corresponding `watchIgnore` field for `Configuration`. These are used to + ignore files in watch mode, which is useful when certain files are + pre-processed and the results are saved into the provider directory + (contribution by Aron Erben) +- Add `Hakyll.Web.Meta` modules `JSONLD`, `OpenGraph`, and `TwitterCard`. These + help with semantic web metadata in pages. This adds dependency on `aeson` + (contribution by Fraser Tweedale) +- Export `Hakyll.Web.Pandoc.Biblio.unCSL` function (contribution by Benjamin + Bray) +- Make the runtime concurrent, which brings 30% speedups on real-world sites. + This adds dependencies on `array` and `lifted-async`. Please note that it + doesn't scale past the number of physical cores; ideas are welcome in + https://github.com/jaspervdj/hakyll/issues/850 (contribution by + Laurent P. René de Cotret and Vaibhav Sagar) +- Fix binary's name in the first tutorial (contribution by Alexander Batischev) +- Fix "Empty 'do' block" error in GitHub tutorial (contribution by + alexandroid000) +- Move #hakyll IRC channel from Freenode to Libera.Chat (by Alexander Batischev + and henk) +- Replace dependency on `cryptonite` and `memory` with dependency on `hashable` + (contribution by Laurent P. René de Cotret) +- Bump `file-embed` upper bound to 0.0.15 (contribution by Alexander Batischev) +- Bump `optparse-applicative` upper bound to 0.16 (contribution by Felix Yan) +- Bump `pandoc` upper bound to 2.14 (contribution by Laurent P. René de Cotret) +- Bump `tasty` upper bound to 1.4 (contribution by Felix Yan) +- Bump `template-haskell` upper bound to 2.17, which is shipped with GHC 9 + (contribution by Alexander Batischev) +- Bump `time` upper bound to 1.11 (contribution by Alexander Batischev) + ## Hakyll 4.14.0.0 (2021-03-14) - Add `renderPandocWithTransform` and `renderPandocWithTransformM` (by Norman diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.14.0.0 +Version: 4.14.1.0 Synopsis: A static website compiler library Description: @@ -22,7 +22,7 @@ . - * An IRC channel, @#hakyll@ on freenode + * An IRC channel, @#hakyll@ on irc.libera.chat (we *do not* have a channel on Freenode anymore) . @@ -146,6 +146,9 @@ Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls + Hakyll.Web.Meta.JSONLD + Hakyll.Web.Meta.OpenGraph + Hakyll.Web.Meta.TwitterCard Hakyll.Web.Paginate Hakyll.Web.Redirect Hakyll.Web.Tags @@ -169,23 +172,25 @@ Paths_hakyll Build-Depends: + aeson >= 1.0 && < 1.6, + array >= 0.5 && < 1, base >= 4.8 && < 5, binary >= 0.5 && < 0.10, blaze-html >= 0.5 && < 0.10, blaze-markup >= 0.5.1 && < 0.9, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.7, - cryptonite >= 0.25 && < 0.28, data-default >= 0.4 && < 0.8, deepseq >= 1.3 && < 1.5, directory >= 1.2.7.0 && < 1.4, - file-embed >= 0.0.10.1 && < 0.0.14, + file-embed >= 0.0.10.1 && < 0.0.16, filepath >= 1.0 && < 1.5, + hashable >= 1.0 && < 2, + lifted-async >= 0.10 && < 1, lrucache >= 1.1.1 && < 1.3, - memory >= 0.14.18 && < 0.16, mtl >= 1 && < 2.3, network-uri >= 2.6 && < 2.7, - optparse-applicative >= 0.12 && < 0.16, + optparse-applicative >= 0.12 && < 0.17, parsec >= 3.0 && < 3.2, process >= 1.6 && < 1.7, random >= 1.0 && < 1.3, @@ -193,9 +198,9 @@ resourcet >= 1.1 && < 1.3, scientific >= 0.3.4 && < 0.4, tagsoup >= 0.13.1 && < 0.15, - template-haskell >= 2.14 && < 2.17, + template-haskell >= 2.14 && < 2.18, text >= 0.11 && < 1.3, - time >= 1.8 && < 1.10, + time >= 1.8 && < 1.12, time-locale-compat >= 0.1 && < 0.2, unordered-containers >= 0.2 && < 0.3, vector >= 0.11 && < 0.13, @@ -237,7 +242,7 @@ Other-Modules: Hakyll.Web.Pandoc.Binary Build-Depends: - pandoc >= 2.11 && < 2.12 + pandoc >= 2.11 && < 2.15 Cpp-options: -DUSE_PANDOC @@ -270,7 +275,7 @@ Build-Depends: hakyll, QuickCheck >= 2.8 && < 2.15, - tasty >= 0.11 && < 1.4, + tasty >= 0.11 && < 1.5, tasty-golden >= 2.3 && < 2.4, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, @@ -333,4 +338,4 @@ base >= 4 && < 5, directory >= 1.0 && < 1.4, filepath >= 1.0 && < 1.5, - pandoc >= 2.11 && < 2.12 + pandoc >= 2.11 && < 2.15 diff --git a/lib/Hakyll.hs b/lib/Hakyll.hs --- a/lib/Hakyll.hs +++ b/lib/Hakyll.hs @@ -20,6 +20,9 @@ , module Hakyll.Web.Feed , module Hakyll.Web.Html , module Hakyll.Web.Html.RelativizeUrls + , module Hakyll.Web.Meta.JSONLD + , module Hakyll.Web.Meta.OpenGraph + , module Hakyll.Web.Meta.TwitterCard , module Hakyll.Web.Paginate #ifdef USE_PANDOC , module Hakyll.Web.Pandoc @@ -53,6 +56,9 @@ import Hakyll.Web.Feed import Hakyll.Web.Html import Hakyll.Web.Html.RelativizeUrls +import Hakyll.Web.Meta.JSONLD +import Hakyll.Web.Meta.OpenGraph +import Hakyll.Web.Meta.TwitterCard import Hakyll.Web.Paginate #ifdef USE_PANDOC import Hakyll.Web.Pandoc diff --git a/lib/Hakyll/Core/Configuration.hs b/lib/Hakyll/Core/Configuration.hs --- a/lib/Hakyll/Core/Configuration.hs +++ b/lib/Hakyll/Core/Configuration.hs @@ -3,6 +3,7 @@ module Hakyll.Core.Configuration ( Configuration (..) , shouldIgnoreFile + , shouldWatchIgnore , defaultConfiguration ) where @@ -12,7 +13,7 @@ import Data.List (isPrefixOf, isSuffixOf) import System.Directory (canonicalizePath) import System.Exit (ExitCode) -import System.FilePath (isAbsolute, normalise, takeFileName) +import System.FilePath (isAbsolute, normalise, takeFileName, makeRelative) import System.IO.Error (catchIOError) import System.Process (system) @@ -45,6 +46,14 @@ -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool + , -- | Function to determine files and directories that should not trigger + -- a rebuild when touched in watch mode. + -- + -- Paths are passed in relative to the providerDirectory. + -- + -- All files that are ignored by 'ignoreFile' are also always ignored by + -- 'watchIgnore'. + watchIgnore :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. -- -- Example: @@ -93,6 +102,7 @@ , tmpDirectory = "_cache/tmp" , providerDirectory = "." , ignoreFile = ignoreFile' + , watchIgnore = const False , deployCommand = "echo 'No deploy command specified' && exit 1" , deploySite = system . deployCommand , inMemoryCache = True @@ -132,3 +142,11 @@ orM :: [IO Bool] -> IO Bool orM [] = return False orM (x : xs) = x >>= \b -> if b then return True else orM xs + +-- | Returns a function to check if a file should be ignored in watch mode +shouldWatchIgnore :: Configuration -> IO (FilePath -> IO Bool) +shouldWatchIgnore conf = do + fullProviderDir <- canonicalizePath $ providerDirectory conf + return (\path -> + let path' = makeRelative fullProviderDir path + in (|| watchIgnore conf path') <$> shouldIgnoreFile conf path) diff --git a/lib/Hakyll/Core/Dependencies.hs b/lib/Hakyll/Core/Dependencies.hs --- a/lib/Hakyll/Core/Dependencies.hs +++ b/lib/Hakyll/Core/Dependencies.hs @@ -33,6 +33,7 @@ data Dependency = PatternDependency Pattern (Set Identifier) | IdentifierDependency Identifier + | AlwaysOutOfDate deriving (Show, Typeable) @@ -40,9 +41,11 @@ instance Binary Dependency where put (PatternDependency p is) = putWord8 0 >> put p >> put is put (IdentifierDependency i) = putWord8 1 >> put i + put AlwaysOutOfDate = putWord8 2 get = getWord8 >>= \t -> case t of 0 -> PatternDependency <$> get <*> get 1 -> IdentifierDependency <$> get + 2 -> pure AlwaysOutOfDate _ -> error "Data.Binary.get: Invalid Dependency" @@ -84,13 +87,30 @@ -------------------------------------------------------------------------------- -dependenciesFor :: Identifier -> DependencyM [Identifier] +-- | Collection of dependencies that should be checked to determine +-- if an identifier needs rebuilding. +data Dependencies + = DependsOn [Identifier] + | MustRebuild + deriving (Show) + +instance Semigroup Dependencies where + DependsOn ids <> DependsOn moreIds = DependsOn (ids <> moreIds) + MustRebuild <> _ = MustRebuild + _ <> MustRebuild = MustRebuild + +instance Monoid Dependencies where + mempty = DependsOn [] + +-------------------------------------------------------------------------------- +dependenciesFor :: Identifier -> DependencyM Dependencies dependenciesFor id' = do facts <- dependencyFacts <$> State.get - return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts + return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts where - dependenciesFor' (IdentifierDependency i) = [i] - dependenciesFor' (PatternDependency _ is) = S.toList is + dependenciesFor' (IdentifierDependency i) = DependsOn [i] + dependenciesFor' (PatternDependency _ is) = DependsOn $ S.toList is + dependenciesFor' AlwaysOutOfDate = MustRebuild -------------------------------------------------------------------------------- @@ -113,6 +133,7 @@ {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds + go _ ds AlwaysOutOfDate = return $ AlwaysOutOfDate : ds go id' ds (PatternDependency p ls) = do universe <- ask let ls' = S.fromList $ filterMatches p universe @@ -136,11 +157,17 @@ check (todo, changed) id' = do deps <- dependenciesFor id' - ood <- dependencyOod <$> State.get - case find (`S.member` ood) deps of - Nothing -> return (id' : todo, changed) - Just d -> do - tell [show id' ++ " is out-of-date because " ++ - show d ++ " is out-of-date"] - markOod id' - return (todo, True) + case deps of + DependsOn depList -> do + ood <- dependencyOod <$> State.get + case find (`S.member` ood) depList of + Nothing -> return (id' : todo, changed) + Just d -> do + tell [show id' ++ " is out-of-date because " ++ + show d ++ " is out-of-date"] + markOod id' + return (todo, True) + MustRebuild -> do + tell [show id' ++ " will be forcibly rebuilt"] + markOod id' + return (todo, True) diff --git a/lib/Hakyll/Core/Rules.hs b/lib/Hakyll/Core/Rules.hs --- a/lib/Hakyll/Core/Rules.hs +++ b/lib/Hakyll/Core/Rules.hs @@ -29,6 +29,7 @@ , preprocess , Dependency (..) , rulesExtraDependencies + , forceCompile ) where @@ -221,3 +222,11 @@ | (i, c) <- rulesCompilers ruleSet ] } + + +-------------------------------------------------------------------------------- +-- | Force the item(s) to always be recompiled, whether or not the +-- dependencies are out of date. This can be useful if you are using +-- I/O to generate part (or all) of an item. +forceCompile :: Rules a -> Rules a +forceCompile = rulesExtraDependencies [AlwaysOutOfDate] diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs --- a/lib/Hakyll/Core/Runtime.hs +++ b/lib/Hakyll/Core/Runtime.hs @@ -5,19 +5,24 @@ -------------------------------------------------------------------------------- -import Control.Monad (unless) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.Reader (ask) -import Control.Monad.RWS (RWST, runRWST) -import Control.Monad.State (get, modify) -import Control.Monad.Trans (liftIO) -import Data.List (intercalate) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import System.Exit (ExitCode (..)) -import System.FilePath (()) +import Control.Concurrent.Async.Lifted (forConcurrently_) +import Control.Concurrent.MVar (modifyMVar_, readMVar, newMVar, MVar) +import Control.Monad (unless) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.Reader (ask) +import Control.Monad.RWS (RWST, runRWST) +import Control.Monad.State (get) +import Control.Monad.Trans (liftIO) +import qualified Data.Array as A +import Data.Graph (Graph) +import qualified Data.Graph as G +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import System.Exit (ExitCode (..)) +import System.FilePath (()) -------------------------------------------------------------------------------- @@ -67,11 +72,13 @@ , runtimeRoutes = rulesRoutes ruleSet , runtimeUniverse = M.fromList compilers } - state = RuntimeState - { runtimeDone = S.empty - , runtimeSnapshots = S.empty - , runtimeTodo = M.empty - , runtimeFacts = oldFacts + + state <- newMVar $ RuntimeState + { runtimeDone = S.empty + , runtimeSnapshots = S.empty + , runtimeTodo = M.empty + , runtimeFacts = oldFacts + , runtimeDependencies = M.empty } -- Run the program and fetch the resulting state @@ -83,7 +90,8 @@ return (ExitFailure 1, ruleSet) Right (_, s, _) -> do - Store.set store factsKey $ runtimeFacts s + facts <- fmap runtimeFacts . liftIO . readMVar $ s + Store.set store factsKey facts Logger.debug logger "Removing tmp directory..." removeDirectory $ tmpDirectory config @@ -107,18 +115,31 @@ -------------------------------------------------------------------------------- data RuntimeState = RuntimeState - { runtimeDone :: Set Identifier - , runtimeSnapshots :: Set (Identifier, Snapshot) - , runtimeTodo :: Map Identifier (Compiler SomeItem) - , runtimeFacts :: DependencyFacts + { runtimeDone :: Set Identifier + , runtimeSnapshots :: Set (Identifier, Snapshot) + , runtimeTodo :: Map Identifier (Compiler SomeItem) + , runtimeFacts :: DependencyFacts + , runtimeDependencies :: Map Identifier (Set Identifier) } -------------------------------------------------------------------------------- -type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a +type Runtime a = RWST RuntimeRead () (MVar RuntimeState) (ExceptT String IO) a -------------------------------------------------------------------------------- +-- Because compilation of rules often revolves around IO, +-- be very careful when modifying the state +modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime () +modifyRuntimeState f = get >>= \s -> liftIO $ modifyMVar_ s (pure . f) + + +-------------------------------------------------------------------------------- +getRuntimeState :: Runtime RuntimeState +getRuntimeState = liftIO . readMVar =<< get + + +-------------------------------------------------------------------------------- build :: Runtime () build = do logger <- runtimeLogger <$> ask @@ -135,13 +156,15 @@ 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 + state <- getRuntimeState + let facts = runtimeFacts state + todo = runtimeTodo state + let (ood, facts', msgs) = outOfDate identifiers modified facts todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe @@ -150,7 +173,7 @@ mapM_ (Logger.debug logger) msgs -- Update facts and todo items - modify $ \s -> s + modifyRuntimeState $ \s -> s { runtimeDone = runtimeDone s `S.union` (S.fromList identifiers `S.difference` ood) , runtimeTodo = todo `M.union` todo' @@ -161,116 +184,138 @@ -------------------------------------------------------------------------------- pickAndChase :: Runtime () pickAndChase = do - todo <- runtimeTodo <$> get - case M.minViewWithKey todo of - Nothing -> return () - Just ((id', _), _) -> do - chase [] id' - pickAndChase + todo <- runtimeTodo <$> getRuntimeState + unless (null todo) $ do + checkForDependencyCycle + forConcurrently_ (M.keys todo) chase + 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' +-- | Check for cyclic dependencies in the current state +checkForDependencyCycle :: Runtime () +checkForDependencyCycle = do + deps <- runtimeDependencies <$> getRuntimeState + let (depgraph, nodeFromVertex, _) = G.graphFromEdges [(k, k, S.toList dps) | (k, dps) <- M.toList deps] + dependencyCycles = map ((\(_, k, _) -> k) . nodeFromVertex) $ cycles depgraph - let compiler = todo M.! id' - read' = CompilerRead - { compilerConfig = config - , compilerUnderlying = id' - , compilerProvider = provider - , compilerUniverse = M.keysSet universe - , compilerRoutes = routes - , compilerStore = store - , compilerLogger = logger + unless (null dependencyCycles) $ do + throwError $ "Hakyll.Core.Runtime.pickAndChase: " ++ + "Dependency cycle detected: " ++ intercalate ", " (map show dependencyCycles) ++ + " are inter-dependent." + where + cycles :: Graph -> [G.Vertex] + cycles g = map fst . filter (uncurry $ reachableFromAny g) . A.assocs $ g + + reachableFromAny :: Graph -> G.Vertex -> [G.Vertex] -> Bool + reachableFromAny graph node = elem node . concatMap (G.reachable graph) + + +-------------------------------------------------------------------------------- +chase :: Identifier -> Runtime () +chase id' = do + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + routes <- runtimeRoutes <$> ask + store <- runtimeStore <$> ask + config <- runtimeConfiguration <$> ask + + state <- getRuntimeState + + Logger.debug logger $ "Processing " ++ show id' + + let compiler = (runtimeTodo state) 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 e -> throwError $ case compilerErrorMessages e of + [] -> "Compiler failed but no info given, try running with -v?" + es -> intercalate "; " es + + -- Signal that a snapshot was saved -> + CompilerSnapshot snapshot c -> do + -- Update info. The next 'chase' will pick us again at some + -- point so we can continue then. + modifyRuntimeState $ \s -> s + { runtimeSnapshots = S.insert (id', snapshot) (runtimeSnapshots s) + , runtimeTodo = M.insert id' c (runtimeTodo s) } - result <- liftIO $ runCompiler compiler read' - case result of - -- Rethrow error - CompilerError e -> throwError $ case compilerErrorMessages e of - [] -> "Compiler failed but no info given, try running with -v?" - es -> intercalate "; " es - -- Signal that a snapshot was saved -> - CompilerSnapshot snapshot c -> do - -- Update info. The next 'chase' will pick us again at some - -- point so we can continue then. - modify $ \s -> s - { runtimeSnapshots = - S.insert (id', snapshot) (runtimeSnapshots s) - , runtimeTodo = M.insert id' c (runtimeTodo s) - } + -- Huge success + CompilerDone (SomeItem item) cwrite -> do + -- Print some info + let facts = compilerDependencies cwrite + cacheHits + | compilerCacheHits cwrite <= 0 = "updated" + | otherwise = "cached " + Logger.message logger $ cacheHits ++ " " ++ show id' - -- 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)" - -- 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 - -- 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 - -- Save! (For load) - liftIO $ save store item + modifyRuntimeState $ \s -> s + { runtimeDone = S.insert id' (runtimeDone s) + , runtimeTodo = M.delete id' (runtimeTodo s) + , runtimeFacts = M.insert id' facts (runtimeFacts s) + } - -- 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 + let (depId, depSnapshot) = dep + Logger.debug logger $ + "Compiler requirement found for: " ++ show id' ++ + ", requirement: " ++ show depId - -- Try something else first - CompilerRequire dep c -> do - -- Update the compiler so we don't execute it twice - let (depId, depSnapshot) = dep - done <- runtimeDone <$> get - snapshots <- runtimeSnapshots <$> get + let done = runtimeDone state + snapshots = runtimeSnapshots state + deps = runtimeDependencies state - -- Done if we either completed the entire item (runtimeDone) or - -- if we previously saved the snapshot (runtimeSnapshots). - let depDone = - depId `S.member` done || - (depId, depSnapshot) `S.member` snapshots + -- Done if we either completed the entire item (runtimeDone) or + -- if we previously saved the snapshot (runtimeSnapshots). + let depDone = + depId `S.member` done || + (depId, depSnapshot) `S.member` snapshots - modify $ \s -> s - { runtimeTodo = M.insert id' - (if depDone then c else compilerResult result) - (runtimeTodo s) - } + let deps' = if depDone + then deps + else M.insertWith S.union id' (S.singleton depId) deps - -- If the required item is already compiled, continue, or, start - -- chasing that - Logger.debug logger $ "Require " ++ show depId ++ - " (snapshot " ++ depSnapshot ++ "): " ++ - (if depDone then "OK" else "chasing") - if depDone then chase trail id' else chase (id' : trail) depId + modifyRuntimeState $ \s -> s + { runtimeTodo = M.insert id' + (if depDone then c else compilerResult result) + (runtimeTodo s) + , runtimeDependencies = deps' + } + + Logger.debug logger $ "Require " ++ show depId ++ + " (snapshot " ++ depSnapshot ++ ") " + diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs --- a/lib/Hakyll/Core/Store.hs +++ b/lib/Hakyll/Core/Store.hs @@ -16,20 +16,14 @@ -------------------------------------------------------------------------------- -import qualified Data.ByteArray as BA -import qualified Crypto.Hash as CH +import qualified Data.Hashable as DH 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 Numeric (showHex) -import System.Directory (createDirectoryIfMissing) -import System.Directory (doesFileExist, removeFile) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) import System.FilePath (()) import System.IO (IOMode (..), hClose, openFile) import System.IO.Error (catchIOError, ioeSetFileName, @@ -194,21 +188,4 @@ -------------------------------------------------------------------------------- -- | Mostly meant for internal usage hash :: [String] -> String -hash = toHex . B.unpack . hashMD5 . T.encodeUtf8 . T.pack . intercalate "/" - where - toHex [] = "" - toHex (x : xs) | x < 16 = '0' : showHex x (toHex xs) - | otherwise = showHex x (toHex xs) - - --------------------------------------------------------------------------------- --- | Hash by MD5 -hashMD5 :: B.ByteString -> B.ByteString -hashMD5 x = - let - digest :: CH.Digest CH.MD5 - digest = CH.hash x - bytes :: B.ByteString - bytes = BA.convert digest - in - bytes +hash = show . DH.hash . intercalate "/" diff --git a/lib/Hakyll/Preview/Poll.hs b/lib/Hakyll/Preview/Poll.hs --- a/lib/Hakyll/Preview/Poll.hs +++ b/lib/Hakyll/Preview/Poll.hs @@ -42,8 +42,9 @@ let providerDir = providerDirectory conf shouldBuild <- newEmptyMVar pattern <- update - fullProviderDir <- canonicalizePath $ providerDirectory conf + fullProviderDir <- canonicalizePath providerDir manager <- FSNotify.startManager + checkIgnore <- shouldWatchIgnore conf let allowed event = do -- Absolute path of the changed file. This must be inside provider @@ -52,8 +53,7 @@ relative = dropWhile (`elem` pathSeparators) $ drop (length fullProviderDir) path identifier = fromFilePath relative - - shouldIgnore <- shouldIgnoreFile conf path + shouldIgnore <- checkIgnore path return $ not shouldIgnore && matches pattern identifier -- This thread continually watches the `shouldBuild` MVar and builds diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs --- a/lib/Hakyll/Web/Html.hs +++ b/lib/Hakyll/Web/Html.hs @@ -7,6 +7,7 @@ -- * Headers , demoteHeaders + , demoteHeadersBy -- * Url manipulation , getUrls @@ -50,13 +51,20 @@ -------------------------------------------------------------------------------- -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc. demoteHeaders :: String -> String -demoteHeaders = withTags $ \tag -> case tag of +demoteHeaders = demoteHeadersBy 1 + +-------------------------------------------------------------------------------- +-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@. +demoteHeadersBy :: Int -> String -> String +demoteHeadersBy amount + | amount < 1 = id + | otherwise = withTags $ \tag -> case tag of TS.TagOpen t a -> TS.TagOpen (demote t) a TS.TagClose t -> TS.TagClose (demote t) t -> t where demote t@['h', n] - | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)] + | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)] | otherwise = t demote t = t diff --git a/lib/Hakyll/Web/Meta/JSONLD.hs b/lib/Hakyll/Web/Meta/JSONLD.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/JSONLD.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + +JSON-LD metadata, using vocabulary +for articles. Google applications and other search engines use +these data to improve search results and links. + +This implementation supports the following fields: + ++-------------------+----------------------------------------------------+ +| @\@type@ | __Hardcoded__ value @\"Article"@. | ++-------------------+----------------------------------------------------+ +| @headline@ | __Required__ taken from context field @title@. | ++-------------------+----------------------------------------------------+ +| @datePublished@ | __Required__ date of publication, via 'dateField'. | ++-------------------+----------------------------------------------------+ + +To use, add a 'jsonldField' to your template context: + +@ +let + context = 'defaultContext' <> … + postContext = + context + <> 'jsonldField' "jsonld" context +@ + +And update the template: + +@ +\ + \$title$\ + \ + $if(jsonld)$$jsonld("embed")$$endif$ +\ +@ + +The @"embed"@ argument generates a @\" + >>= compileTemplateItem diff --git a/lib/Hakyll/Web/Meta/OpenGraph.hs b/lib/Hakyll/Web/Meta/OpenGraph.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/OpenGraph.hs @@ -0,0 +1,71 @@ +{- | + +Open Graph metadata, as described at . This +implementation supports the following properties: + ++------------------+----------------------------------------------------+ +| @og:type@ | __Hardcoded__ value @"article"@ | ++------------------+----------------------------------------------------+ +| @og:url@ | __Required__ concatenation of @root@ and @url@ | +| | context fields, both of which are required. | ++------------------+----------------------------------------------------+ +| @og:title@ | __Required__ title of article, from @title@ field. | ++------------------+----------------------------------------------------+ +| @og:description@ | __Optional__ brief description taken from context | +| | field @og-description@, if set. | ++------------------+----------------------------------------------------+ +| @og:image@ | __Optional__ image URL taken from context | +| | field @og-image@, if set. | ++------------------+----------------------------------------------------+ + +To use, add 'openGraphField' to the template context: + +@ +let + context = 'defaultContext' <> … + postContext = context <> 'openGraphField' "opengraph" context +@ + +and update the template: + +@ +\ + \$title$ + \ + $if(opengraph)$$opengraph$$endif$ +\ +@ + +See also "Hakyll.Web.Meta.TwitterCard". + +-} +module Hakyll.Web.Meta.OpenGraph + ( openGraphField + ) where + +import Hakyll.Core.Compiler +import Hakyll.Core.Item +import Hakyll.Web.Template +import Hakyll.Web.Template.Context + +openGraphField :: String -> Context String -> Context String +openGraphField k ctx = functionField k $ \_args i -> do + template <- openGraphTemplate + itemBody <$> applyTemplate template ctx i + +openGraphTemplate :: Compiler Template +openGraphTemplate = do + makeItem openGraphTemplateString >>= compileTemplateItem + +openGraphTemplateString :: String +openGraphTemplateString = + "\ + \\ + \\ + \$if(og-description)$\ + \\ + \$endif$\ + \$if(og-image)$\ + \\ + \$endif$\ + \" diff --git a/lib/Hakyll/Web/Meta/TwitterCard.hs b/lib/Hakyll/Web/Meta/TwitterCard.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Web/Meta/TwitterCard.hs @@ -0,0 +1,63 @@ +{- | + +Twitter Card metadata, as described at +. +This feature should be used alongside "Hakyll.Web.Meta.OpenGraph". +The following properties are supported: + ++-------------------+----------------------------------------------------+ +| @twitter:card@ | __Hardcoded__ card type = @"summary"@. | ++-------------------+----------------------------------------------------+ +| @twitter:creator@ | __Optional__ author's Twitter user name. | +| | Taken from @twitter-creator@ context field, if set.| ++-------------------+----------------------------------------------------+ +| @twitter:site@ | __Optional__ publication's Twitter user name. | +| | Taken from @twitter-site@ context field, if set. | ++-------------------+----------------------------------------------------+ + +To use, add 'openGraphField' and 'twitterCardField' to the template context: + +@ +let + context = 'defaultContext' <> … + postContext = + context + <> 'openGraphField' "opengraph" context + <> 'twitterCardField' "twitter" context +@ + +and update the template: + +@ +\ + \$title$\ + \ + $if(opengraph)$$opengraph$$endif$ + $if(twitter)$$twitter$$endif$ +\ +@ + +-} +module Hakyll.Web.Meta.TwitterCard + ( twitterCardField + ) where + +import Hakyll.Core.Compiler +import Hakyll.Core.Item +import Hakyll.Web.Template +import Hakyll.Web.Template.Context + +twitterCardField :: String -> Context String -> Context String +twitterCardField k ctx = functionField k $ \_args i -> do + template <- twitterCardTemplate + itemBody <$> applyTemplate template ctx i + +twitterCardTemplate :: Compiler Template +twitterCardTemplate = do + makeItem twitterCardTemplateString >>= compileTemplateItem + +twitterCardTemplateString :: String +twitterCardTemplateString = + "\ + \$if(twitter-creator)$$endif$\ + \$if(twitter-site)$$endif$" diff --git a/lib/Hakyll/Web/Pandoc/Biblio.hs b/lib/Hakyll/Web/Pandoc/Biblio.hs --- a/lib/Hakyll/Web/Pandoc/Biblio.hs +++ b/lib/Hakyll/Web/Pandoc/Biblio.hs @@ -14,7 +14,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Pandoc.Biblio - ( CSL + ( CSL (..) , cslCompiler , Biblio (..) , biblioCompiler diff --git a/lib/Hakyll/Web/Tags.hs b/lib/Hakyll/Web/Tags.hs --- a/lib/Hakyll/Web/Tags.hs +++ b/lib/Hakyll/Web/Tags.hs @@ -43,6 +43,7 @@ module Hakyll.Web.Tags ( Tags (..) , getTags + , getTagsByField , getCategory , buildTagsWith , buildTags @@ -105,11 +106,16 @@ -- | Obtain tags from a page in the default way: parse them from the @tags@ -- metadata field. This can either be a list or a comma-separated string. getTags :: MonadMetadata m => Identifier -> m [String] -getTags identifier = do +getTags = getTagsByField "tags" + +-- | Obtain tags from a page by name of the metadata field. These can be a list +-- or a comma-separated string +getTagsByField :: MonadMetadata m => String -> Identifier -> m [String] +getTagsByField fieldName identifier = do metadata <- getMetadata identifier return $ fromMaybe [] $ - (lookupStringList "tags" metadata) `mplus` - (map trim . splitAll "," <$> lookupString "tags" metadata) + (lookupStringList fieldName metadata) `mplus` + (map trim . splitAll "," <$> lookupString fieldName metadata) -------------------------------------------------------------------------------- diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -120,7 +120,7 @@ , " main-is: site.hs" , " build-depends: base == 4.*" , " , hakyll == " ++ version' ++ ".*" - , " ghc-options: -threaded" + , " ghc-options: -threaded -rtsopts -with-rtsopts=-N" , " default-language: Haskell2010" ] where diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/tests/Hakyll/Core/Runtime/Tests.hs @@ -8,6 +8,7 @@ -------------------------------------------------------------------------------- import qualified Data.ByteString as B import System.FilePath (()) +import System.Exit (ExitCode (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, (@?=)) @@ -22,7 +23,7 @@ -------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Hakyll.Core.Runtime.Tests" $ - fromAssertions "run" [case01, case02] + fromAssertions "run" [case01, case02, case03] -------------------------------------------------------------------------------- @@ -92,5 +93,32 @@ favicon <- readFile $ destinationDirectory testConfiguration "favicon.ico" favicon @?= "Test" + + cleanTestEnv + + +-------------------------------------------------------------------------------- +-- Test that dependency cycles are correctly identified +case03 :: Assertion +case03 = do + logger <- Logger.new Logger.Error + (ec, _) <- run testConfiguration logger $ do + + create ["partial.html.out1"] $ do + route idRoute + compile $ do + example <- loadSnapshotBody "partial.html.out2" "raw" + makeItem example + >>= loadAndApplyTemplate "partial.html" defaultContext + + create ["partial.html.out2"] $ do + route idRoute + compile $ do + example <- loadSnapshotBody "partial.html.out1" "raw" + makeItem example + >>= loadAndApplyTemplate "partial.html" defaultContext + + + ec @?= ExitFailure 1 cleanTestEnv diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs --- a/tests/Hakyll/Web/Html/Tests.hs +++ b/tests/Hakyll/Web/Html/Tests.hs @@ -20,7 +20,18 @@ tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "

A h1 title

" @=? - demoteHeaders "

A h1 title

" + demoteHeaders "

A h1 title

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

A h1 title

" @=? + demoteHeadersBy 2 "

A h1 title

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

A h4 title

" @=? + demoteHeadersBy 0 "

A h4 title

" -- Assert that a demotion of @N < 1@ is a no-op. ] , fromAssertions "withUrls"