hakyll 4.14.0.0 → 4.14.1.0
raw patch · 18 files changed
+615/−186 lines, 18 filesdep +aesondep +arraydep +hashabledep −cryptonitedep −memorydep ~file-embeddep ~optparse-applicativedep ~pandocnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: aeson, array, hashable, lifted-async
Dependencies removed: cryptonite, memory
Dependency ranges changed: file-embed, optparse-applicative, pandoc, tasty, template-haskell, time
API changes (from Hackage documentation)
- Hakyll.Web.Pandoc.Biblio: data CSL
+ Hakyll.Core.Configuration: [watchIgnore] :: Configuration -> FilePath -> Bool
+ Hakyll.Core.Configuration: shouldWatchIgnore :: Configuration -> IO (FilePath -> IO Bool)
+ Hakyll.Core.Dependencies: AlwaysOutOfDate :: Dependency
+ Hakyll.Core.Dependencies: instance GHC.Base.Monoid Hakyll.Core.Dependencies.Dependencies
+ Hakyll.Core.Dependencies: instance GHC.Base.Semigroup Hakyll.Core.Dependencies.Dependencies
+ Hakyll.Core.Dependencies: instance GHC.Show.Show Hakyll.Core.Dependencies.Dependencies
+ Hakyll.Core.Rules: AlwaysOutOfDate :: Dependency
+ Hakyll.Core.Rules: forceCompile :: Rules a -> Rules a
+ Hakyll.Web.Html: demoteHeadersBy :: Int -> String -> String
+ Hakyll.Web.Meta.JSONLD: jsonldField :: String -> Context String -> Context String
+ Hakyll.Web.Meta.OpenGraph: openGraphField :: String -> Context String -> Context String
+ Hakyll.Web.Meta.TwitterCard: twitterCardField :: String -> Context String -> Context String
+ Hakyll.Web.Pandoc.Biblio: CSL :: ByteString -> CSL
+ Hakyll.Web.Pandoc.Biblio: [unCSL] :: CSL -> ByteString
+ Hakyll.Web.Pandoc.Biblio: newtype CSL
+ Hakyll.Web.Tags: getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]
- Hakyll.Core.Configuration: Configuration :: FilePath -> FilePath -> FilePath -> FilePath -> (FilePath -> Bool) -> String -> (Configuration -> IO ExitCode) -> Bool -> String -> Int -> Configuration
+ Hakyll.Core.Configuration: Configuration :: FilePath -> FilePath -> FilePath -> FilePath -> (FilePath -> Bool) -> (FilePath -> Bool) -> String -> (Configuration -> IO ExitCode) -> Bool -> String -> Int -> Configuration
Files
- CHANGELOG.md +40/−0
- hakyll.cabal +16/−11
- lib/Hakyll.hs +6/−0
- lib/Hakyll/Core/Configuration.hs +19/−1
- lib/Hakyll/Core/Dependencies.hs +39/−12
- lib/Hakyll/Core/Rules.hs +9/−0
- lib/Hakyll/Core/Runtime.hs +169/−124
- lib/Hakyll/Core/Store.hs +3/−26
- lib/Hakyll/Preview/Poll.hs +3/−3
- lib/Hakyll/Web/Html.hs +10/−2
- lib/Hakyll/Web/Meta/JSONLD.hs +115/−0
- lib/Hakyll/Web/Meta/OpenGraph.hs +71/−0
- lib/Hakyll/Web/Meta/TwitterCard.hs +63/−0
- lib/Hakyll/Web/Pandoc/Biblio.hs +1/−1
- lib/Hakyll/Web/Tags.hs +9/−3
- src/Init.hs +1/−1
- tests/Hakyll/Core/Runtime/Tests.hs +29/−1
- tests/Hakyll/Web/Html/Tests.hs +12/−1
CHANGELOG.md view
@@ -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
hakyll.cabal view
@@ -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
lib/Hakyll.hs view
@@ -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
lib/Hakyll/Core/Configuration.hs view
@@ -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)
lib/Hakyll/Core/Dependencies.hs view
@@ -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)
lib/Hakyll/Core/Rules.hs view
@@ -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]
lib/Hakyll/Core/Runtime.hs view
@@ -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 ++ ") "+
lib/Hakyll/Core/Store.hs view
@@ -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 "/"
lib/Hakyll/Preview/Poll.hs view
@@ -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
lib/Hakyll/Web/Html.hs view
@@ -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
+ lib/Hakyll/Web/Meta/JSONLD.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary+for articles. Google applications and other search engines use+these data to improve search results and links.++This implementation supports the following fields:+++-------------------+----------------------------------------------------++| @\@type@ | __Hardcoded__ value @\"Article"@. |++-------------------+----------------------------------------------------++| @headline@ | __Required__ taken from context field @title@. |++-------------------+----------------------------------------------------++| @datePublished@ | __Required__ date of publication, via 'dateField'. |++-------------------+----------------------------------------------------+++To use, add a 'jsonldField' to your template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'jsonldField' "jsonld" context+@++And update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(jsonld)$$jsonld("embed")$$endif$+\</head>+@++The @"embed"@ argument generates a @\<script …>@ tag to be directly+included in page HTML. To get the raw JSON string, use @"raw"@+instead.++-}+module Hakyll.Web.Meta.JSONLD+ ( jsonldField+ ) where++import Data.Aeson ((.=), pairs)+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++runContext :: Context String -> String -> Compiler String+runContext ctx k = do+ i <- makeItem "dummy"+ unContext ctx k [] i >>= \cf -> case cf of+ StringField s -> pure s+ _ -> fail $ "Error: '" <> k <> "' is not a StringField"++getContext :: Context String -> String -> Compiler String+getContext ctx k = compilerTry (runContext ctx k) >>= either f pure+ where+ f (CompilationNoResult _) = compilerResult . CompilerError . CompilationFailure . pure $+ "missing required field '" <> k <> "'"+ f err = compilerResult (CompilerError err)++-- This may come in handy later+_lookupContext :: Context String -> String -> Compiler (Maybe String)+_lookupContext ctx k = compilerTry (runContext ctx k) >>= either f (pure . Just)+ where+ f (CompilationNoResult _) = pure Nothing+ f err = compilerResult (CompilerError err)++-- | Render JSON-LD for an article.+-- Requires context with "title", and the item must be able to yield+-- a valid date via 'getItemUTC'+--+renderJSONLD :: Context String -> Compiler (Item String)+renderJSONLD ctx = do+ dateString <- getContext (dateField "" "%Y-%m-%dT%H:%M:%S") ""+ titleString <- getContext ctx "title"++ let+ obj = pairs $+ "@context" .= ("https://schema.org" :: String)+ <> "@type" .= ("Article" :: String)+ <> "headline" .= titleString+ <> "datePublished" .= dateString++ makeItem . LT.unpack . LT.decodeUtf8 . encodingToLazyByteString $ obj++jsonldField :: String -> Context String -> Context String+jsonldField k ctx = functionField k (\args _i -> go args)+ where+ -- The zero argument case cannot be a compiler error,+ -- otherwise @$if(k)$@ evaluates false.+ go [] = pure $ "<!-- Whoops! Try this instead: $if(" <> k <> ")$$" <> k <> "(\"embed\")$$endif$ -->"+ go ["raw"] = itemBody <$> renderJSONLD ctx+ go ["embed"] = do+ template <- jsonldTemplate+ i <- renderJSONLD ctx >>= applyTemplate template (bodyField "body")+ pure $ itemBody i+ go [_] = fail $ "invalid argument to jsonldField '" <> k <> "'. use \"raw\" or \"embed\""+ go _ = fail $ "too many arguments to jsonldField '" <> k <> "'"++jsonldTemplate :: Compiler Template+jsonldTemplate = do+ makeItem "<script type=\"application/ld+json\">$body$</script>"+ >>= compileTemplateItem
+ lib/Hakyll/Web/Meta/OpenGraph.hs view
@@ -0,0 +1,71 @@+{- |++Open Graph metadata, as described at <https://ogp.me/>. This+implementation supports the following properties:+++------------------+----------------------------------------------------++| @og:type@ | __Hardcoded__ value @"article"@ |++------------------+----------------------------------------------------++| @og:url@ | __Required__ concatenation of @root@ and @url@ |+| | context fields, both of which are required. |++------------------+----------------------------------------------------++| @og:title@ | __Required__ title of article, from @title@ field. |++------------------+----------------------------------------------------++| @og:description@ | __Optional__ brief description taken from context |+| | field @og-description@, if set. |++------------------+----------------------------------------------------++| @og:image@ | __Optional__ image URL taken from context |+| | field @og-image@, if set. |++------------------+----------------------------------------------------+++To use, add 'openGraphField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext = context <> 'openGraphField' "opengraph" context+@++and update the template:++@+\<head>+ \<title>$title$</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+\</head>+@++See also "Hakyll.Web.Meta.TwitterCard".++-}+module Hakyll.Web.Meta.OpenGraph+ ( openGraphField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++openGraphField :: String -> Context String -> Context String+openGraphField k ctx = functionField k $ \_args i -> do+ template <- openGraphTemplate+ itemBody <$> applyTemplate template ctx i++openGraphTemplate :: Compiler Template+openGraphTemplate = do+ makeItem openGraphTemplateString >>= compileTemplateItem++openGraphTemplateString :: String+openGraphTemplateString =+ "<meta property=\"og:type\" content=\"article\" />\+ \<meta property=\"og:url\" content=\"$root$$url$\" />\+ \<meta property=\"og:title\" content=\"$title$\" />\+ \$if(og-description)$\+ \<meta property=\"og:description\" content=\"$og-description$\" />\+ \$endif$\+ \$if(og-image)$\+ \<meta property=\"og:image\" content=\"$og-image$\" />\+ \$endif$\+ \"
+ lib/Hakyll/Web/Meta/TwitterCard.hs view
@@ -0,0 +1,63 @@+{- |++Twitter Card metadata, as described at+<https://developer.twitter.com/en/docs/twitter-for-websites/cards/guides/getting-started>.+This feature should be used alongside "Hakyll.Web.Meta.OpenGraph".+The following properties are supported:+++-------------------+----------------------------------------------------++| @twitter:card@ | __Hardcoded__ card type = @"summary"@. |++-------------------+----------------------------------------------------++| @twitter:creator@ | __Optional__ author's Twitter user name. |+| | Taken from @twitter-creator@ context field, if set.|++-------------------+----------------------------------------------------++| @twitter:site@ | __Optional__ publication's Twitter user name. |+| | Taken from @twitter-site@ context field, if set. |++-------------------+----------------------------------------------------+++To use, add 'openGraphField' and 'twitterCardField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'openGraphField' "opengraph" context+ <> 'twitterCardField' "twitter" context+@++and update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+ $if(twitter)$$twitter$$endif$+\</head>+@++-}+module Hakyll.Web.Meta.TwitterCard+ ( twitterCardField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++twitterCardField :: String -> Context String -> Context String+twitterCardField k ctx = functionField k $ \_args i -> do+ template <- twitterCardTemplate+ itemBody <$> applyTemplate template ctx i++twitterCardTemplate :: Compiler Template+twitterCardTemplate = do+ makeItem twitterCardTemplateString >>= compileTemplateItem++twitterCardTemplateString :: String+twitterCardTemplateString =+ "<meta name=\"twitter:card\" content=\"summary\" />\+ \$if(twitter-creator)$<meta property=\"twitter:creator\" content=\"$twitter-creator$\" />$endif$\+ \$if(twitter-site)$<meta property=\"twitter:site\" content=\"$twitter-site$\" />$endif$"
lib/Hakyll/Web/Pandoc/Biblio.hs view
@@ -14,7 +14,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Pandoc.Biblio- ( CSL+ ( CSL (..) , cslCompiler , Biblio (..) , biblioCompiler
lib/Hakyll/Web/Tags.hs view
@@ -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) --------------------------------------------------------------------------------
src/Init.hs view
@@ -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
tests/Hakyll/Core/Runtime/Tests.hs view
@@ -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
tests/Hakyll/Web/Html/Tests.hs view
@@ -20,7 +20,18 @@ tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "<h2>A h1 title</h2>" @=?- demoteHeaders "<h1>A h1 title</h1>"+ demoteHeaders "<h1>A h1 title</h1>" -- Assert single-step demotion+ , "<h6>A h6 title</h6>" @=?+ demoteHeaders "<h6>A h6 title</h6>" -- Assert maximum demotion is h6+ ]++ , fromAssertions "demoteHeadersBy"+ [ "<h3>A h1 title</h3>" @=?+ demoteHeadersBy 2 "<h1>A h1 title</h1>"+ , "<h6>A h5 title</h6>" @=?+ demoteHeadersBy 2 "<h5>A h5 title</h5>" -- Assert that h6 is the lowest possible demoted header.+ , "<h4>A h4 title</h4>" @=?+ demoteHeadersBy 0 "<h4>A h4 title</h4>" -- Assert that a demotion of @N < 1@ is a no-op. ] , fromAssertions "withUrls"