diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,14 @@ # Releases +## Hakyll 4.16.1.0 (2023-08-23) + +- Rewrite async scheduler; improves scaling and resource usage +- Add JSON Feed support (contribution by Berk Özkütük) +- Bump `aeson` upper bound to aeson 2.3 (contribution by Alexander Batischev) +- Bump `optparse-applicative` upper bound to aeson 0.19 (contribution by + Alexander Batischev) + ## Hakyll 4.16.0.0 (2023-04-27) - Bump `base` *lower* bound to 4.12 (GHC >= 8.6). Hakyll already failed to build diff --git a/data/templates/feed-item.json b/data/templates/feed-item.json new file mode 100644 --- /dev/null +++ b/data/templates/feed-item.json @@ -0,0 +1,8 @@ +{ + "id": "$root$$url$", + "url": "$root$$url$", + "content_html": "$description$", + "title": "$title$", + "date_published": "$published$", + "date_modified": "$updated$" +} diff --git a/data/templates/feed.json b/data/templates/feed.json new file mode 100644 --- /dev/null +++ b/data/templates/feed.json @@ -0,0 +1,17 @@ +{ + "version": "https://www.jsonfeed.org/version/1.1", + "title": "$title$", + "home_page_url": "$root$", + "feed_url": "$root$$url$", + $if(authorName)$ + "authors": [ + { + "name": "$authorName$" + $if(authorEmail)$ + , "url": "mailto:$authorEmail$" + $endif$ + } + ], + $endif$ + "items": [ $body$ ] +} diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.16.0.0 +Version: 4.16.1.0 Synopsis: A static website compiler library Description: @@ -92,6 +92,8 @@ data/templates/atom.xml data/templates/rss-item.xml data/templates/rss.xml + data/templates/feed.json + data/templates/feed-item.json Source-Repository head Type: git @@ -179,7 +181,7 @@ Paths_hakyll Build-Depends: - aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.2, + aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3, base >= 4.12 && < 5, binary >= 0.5 && < 0.10, blaze-html >= 0.5 && < 0.10, @@ -192,11 +194,10 @@ 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, mtl >= 1 && < 2.4, network-uri >= 2.6 && < 2.7, - optparse-applicative >= 0.12 && < 0.18, + optparse-applicative >= 0.12 && < 0.19, parsec >= 3.0 && < 3.2, process >= 1.6 && < 1.7, random >= 1.0 && < 1.3, @@ -286,7 +287,7 @@ tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, -- Copy pasted from hakyll dependencies: - aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.2, + aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3, base >= 4.12 && < 5, bytestring >= 0.9 && < 0.12, containers >= 0.3 && < 0.7, diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs --- a/lib/Hakyll/Core/Logger.hs +++ b/lib/Hakyll/Core/Logger.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs +{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Logger ( Verbosity (..) , Logger @@ -9,15 +10,19 @@ , header , message , debug + + -- * Testing utilities + , newInMem ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Monad (forever) +import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Monad (forever, when) import Control.Monad.Trans (MonadIO, liftIO) +import qualified Data.IORef as IORef import Data.List (intercalate) import Prelude hiding (error) @@ -31,12 +36,10 @@ -------------------------------------------------------------------------------- --- | Logger structure. Very complicated. data Logger = Logger - { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end - , loggerSync :: MVar () -- ^ Used for sync on quit - , loggerSink :: String -> IO () -- ^ Out sink - , loggerVerbosity :: Verbosity -- ^ Verbosity + { -- | Flush the logger (blocks until flushed) + flush :: forall m. MonadIO m => m () + , string :: forall m. MonadIO m => Verbosity -> String -> m () } @@ -44,38 +47,23 @@ -- | Create a new logger new :: Verbosity -> IO Logger new vbty = do - logger <- Logger <$> - newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty - _ <- forkIO $ loggerThread logger - return logger - where - loggerThread logger = forever $ do - msg <- readChan $ loggerChan logger + chan <- newChan + sync <- newEmptyMVar + _ <- forkIO $ forever $ do + msg <- readChan chan case msg of -- Stop: sync - Nothing -> putMVar (loggerSync logger) () + Nothing -> putMVar sync () -- Print and continue - Just m -> loggerSink logger m - - --------------------------------------------------------------------------------- --- | 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 () + Just m -> putStrLn m + return $ Logger + { flush = liftIO $ do + writeChan chan Nothing + () <- takeMVar sync + return () + , string = \v m -> when (vbty >= v) $ + liftIO $ writeChan chan (Just m) + } -------------------------------------------------------------------------------- @@ -101,3 +89,19 @@ -------------------------------------------------------------------------------- indent :: String -> String indent = intercalate "\n " . lines + + +-------------------------------------------------------------------------------- +-- | Create a new logger that just stores all the messages, useful for writing +-- tests. +newInMem :: IO (Logger, IO [(Verbosity, String)]) +newInMem = do + ref <- IORef.newIORef [] + pure + ( Logger + { string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $ + \msgs -> ((vbty, msg) : msgs, ()) + , flush = pure () + } + , reverse <$> IORef.readIORef ref + ) diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs --- a/lib/Hakyll/Core/Runtime.hs +++ b/lib/Hakyll/Core/Runtime.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} module Hakyll.Core.Runtime ( run , RunMode(..) @@ -6,21 +7,26 @@ -------------------------------------------------------------------------------- -import Control.Concurrent.Async.Lifted (forConcurrently) -import Control.Concurrent.MVar (modifyMVar_, readMVar, newMVar, MVar) -import Control.Monad (join, unless, when) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Trans (liftIO) -import Data.Foldable (traverse_) -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 Data.Traversable (for) -import System.Exit (ExitCode (..)) -import System.FilePath (()) +import Control.Concurrent (forkIO, getNumCapabilities, + rtsSupportsBoundThreads) +import qualified Control.Concurrent.MVar as MVar +import Control.Monad (replicateM_, unless, void) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans (liftIO) +import Data.Foldable (for_, traverse_) +import qualified Data.Graph as Graph +import Data.IORef (IORef) +import qualified Data.IORef as IORef +import Data.List (foldl', intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import System.Exit (ExitCode (..)) +import System.FilePath (()) -------------------------------------------------------------------------------- @@ -70,40 +76,34 @@ let (oldFacts) = case mOldFacts of Store.Found f -> f _ -> mempty - state <- newMVar $ RuntimeState - { runtimeDone = S.empty - , runtimeSnapshots = S.empty - , runtimeTodo = M.empty - , runtimeFacts = oldFacts - , runtimeDependencies = M.empty - } - -- Build runtime read/state + scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts} let compilers = rulesCompilers ruleSet read' = RuntimeRead { runtimeConfiguration = config , runtimeLogger = logger , runtimeProvider = provider - , runtimeState = state , runtimeStore = store , runtimeRoutes = rulesRoutes ruleSet - , runtimeUniverse = M.fromList compilers + , runtimeUniverse = Map.fromList compilers + , runtimeScheduler = scheduler } -- Run the program and fetch the resulting state - result <- runExceptT $ runReaderT (build mode) read' - case result of - Left e -> do - Logger.error logger e - Logger.flush logger - return (ExitFailure 1, ruleSet) - - Right _ -> do - Logger.debug logger "Removing tmp directory..." - removeDirectory $ tmpDirectory config + runReaderT (build mode) read' + errors <- schedulerErrors <$> IORef.readIORef scheduler + if null errors then do + Logger.debug logger "Removing tmp directory..." + removeDirectory $ tmpDirectory config - Logger.flush logger - return (ExitSuccess, ruleSet) + Logger.flush logger + return (ExitSuccess, ruleSet) + else do + for_ errors $ \(mbId, err) -> Logger.error logger $ case mbId of + Just identifier -> show identifier <> ": " <> err + Nothing -> err + Logger.flush logger + return (ExitFailure 1, ruleSet) -------------------------------------------------------------------------------- @@ -111,163 +111,352 @@ { runtimeConfiguration :: Configuration , runtimeLogger :: Logger , runtimeProvider :: Provider - , runtimeState :: MVar RuntimeState , runtimeStore :: Store , runtimeRoutes :: Routes , runtimeUniverse :: Map Identifier (Compiler SomeItem) + , runtimeScheduler :: IORef Scheduler } -------------------------------------------------------------------------------- -data RuntimeState = RuntimeState - { runtimeDone :: Set Identifier - , runtimeSnapshots :: Set (Identifier, Snapshot) - , runtimeTodo :: Map Identifier (Compiler SomeItem) - , runtimeFacts :: DependencyFacts - , runtimeDependencies :: Map Identifier (Set (Identifier, Snapshot)) +-- | A Scheduler is a pure representation of work going on, works that needs +-- to be done, and work already done. Workers can obtain things to do +-- by interacting with the Scheduler, and execute them synchronously or +-- asynchronously. +-- +-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and +-- should be used with atomicModifyIORef'. +data Scheduler = Scheduler + { -- | Items to work on next. Identifiers may appear multiple times. + schedulerQueue :: !(Seq Identifier) + , -- | Items that we haven't started yet. + schedulerTodo :: !(Map Identifier (Compiler SomeItem)) + , -- | Currently processing + schedulerWorking :: !(Set Identifier) + , -- | Finished + schedulerDone :: !(Set Identifier) + , -- | Any snapshots stored. + schedulerSnapshots :: !(Set (Identifier, Snapshot)) + , -- | Currently blocked compilers. + schedulerBlocked :: !(Set Identifier) + , -- | Compilers that may resume on triggers + schedulerTriggers :: !(Map Identifier (Set Identifier)) + , -- | Number of starved pops; tracking this allows us to start a new + -- number of threads again later. + schedulerStarved :: !Int + , -- | Dynamic dependency info. + schedulerFacts :: !DependencyFacts + , -- | Errors encountered. + schedulerErrors :: ![(Maybe Identifier, String)] } -------------------------------------------------------------------------------- -type Runtime a = ReaderT RuntimeRead (ExceptT String IO) a +emptyScheduler :: Scheduler +emptyScheduler = Scheduler {..} + where + schedulerTodo = Map.empty + schedulerDone = Set.empty + schedulerQueue = Seq.empty + schedulerWorking = Set.empty + schedulerSnapshots = Set.empty + schedulerBlocked = Set.empty + schedulerTriggers = Map.empty + schedulerStarved = 0 + schedulerFacts = Map.empty + schedulerErrors = [] -------------------------------------------------------------------------------- --- Because compilation of rules often revolves around IO, --- be very careful when modifying the state -modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime () -modifyRuntimeState f = liftIO . flip modifyMVar_ (pure . f) . runtimeState =<< ask +schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ()) +schedulerError i e s = (s {schedulerErrors = (i, e) : schedulerErrors s}, ()) -------------------------------------------------------------------------------- -getRuntimeState :: Runtime RuntimeState -getRuntimeState = liftIO . readMVar . runtimeState =<< ask +schedulerMarkOutOfDate + :: Map Identifier (Compiler SomeItem) + -> Set Identifier + -> Scheduler + -> (Scheduler, [String]) +schedulerMarkOutOfDate universe modified scheduler@Scheduler {..} = + ( scheduler + { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo) + , schedulerDone = schedulerDone <> + (Map.keysSet universe `Set.difference` ood) + , schedulerTodo = schedulerTodo <> todo + , schedulerFacts = facts' + } + , msgs + ) + where + (ood, facts', msgs) = outOfDate (Map.keys universe) modified schedulerFacts + todo = Map.filterWithKey (\id' _ -> id' `Set.member` ood) universe -------------------------------------------------------------------------------- -build :: RunMode -> Runtime () +data SchedulerStep + -- | The scheduler instructs to offer some work on the given item. It + -- also returns the number of threads that can be resumed after they have + -- starved. + = SchedulerWork Identifier (Compiler SomeItem) Int + -- | There's currently no work available, but there will be after other + -- threads have finished whatever they are doing. + | SchedulerStarve + -- | We've finished all work. + | SchedulerFinish + -- | An error occurred. You can retrieve the errors from 'schedulerErrors'. + | SchedulerError + + +-------------------------------------------------------------------------------- +schedulerPop :: Scheduler -> (Scheduler, SchedulerStep) +schedulerPop scheduler@Scheduler {..} = case Seq.viewl schedulerQueue of + Seq.EmptyL + | not $ Set.null schedulerWorking -> + ( scheduler {schedulerStarved = schedulerStarved + 1} + , SchedulerStarve + ) + | not $ Set.null schedulerBlocked -> + let cycles = schedulerCycles scheduler + msg | null cycles = "Possible dependency cycle in: " <> + intercalate ", " (show <$> Set.toList schedulerBlocked) + | otherwise = "Dependency cycles: " <> + intercalate "; " + (map (intercalate " -> " . map show) cycles) in + SchedulerError <$ schedulerError Nothing msg scheduler + | otherwise -> (scheduler, SchedulerFinish) + x Seq.:< xs + | x `Set.member` schedulerDone -> + schedulerPop scheduler {schedulerQueue = xs} + | x `Set.member` schedulerWorking -> + schedulerPop scheduler {schedulerQueue = xs} + | x `Set.member` schedulerBlocked -> + schedulerPop scheduler {schedulerQueue = xs} + | otherwise -> case Map.lookup x schedulerTodo of + Nothing -> SchedulerError <$ + schedulerError (Just x) "Compiler not found" scheduler + Just c -> + ( scheduler + { schedulerQueue = xs + , schedulerWorking = Set.insert x schedulerWorking + } + , SchedulerWork x c 0 + ) + + +-------------------------------------------------------------------------------- +schedulerCycles :: Scheduler -> [[Identifier]] +schedulerCycles Scheduler {..} = + [c | Graph.CyclicSCC c <- Graph.stronglyConnComp graph] + where + graph = [(x, x, Set.toList ys) | (x, ys) <- Map.toList edges] + edges = Map.fromListWith Set.union $ do + (dep, xs) <- Map.toList $ schedulerTriggers + x <- Set.toList xs + pure (x, Set.singleton dep) + + +-------------------------------------------------------------------------------- +schedulerBlock + :: Identifier + -> [(Identifier, Snapshot)] + -> Compiler SomeItem + -> Scheduler + -> (Scheduler, SchedulerStep) +schedulerBlock identifier deps0 compiler scheduler@Scheduler {..} + | null deps1 = (scheduler, SchedulerWork identifier compiler 0) + | otherwise = schedulerPop $ scheduler + { schedulerQueue = + -- Optimization: move deps to the front and item to the back + Seq.fromList depIds <> + schedulerQueue <> + Seq.singleton identifier + , schedulerTodo = + Map.insert identifier + (Compiler $ \_ -> pure $ CompilerRequire deps0 compiler) + schedulerTodo + , schedulerWorking = Set.delete identifier schedulerWorking + , schedulerBlocked = Set.insert identifier schedulerBlocked + , schedulerTriggers = foldl' + (\acc (depId, _) -> + Map.insertWith Set.union depId (Set.singleton identifier) acc) + schedulerTriggers + deps1 + } + where + deps1 = filter (not . done) deps0 + depIds = map fst deps1 + + -- Done if we either completed the entire item (runtimeDone) or + -- if we previously saved the snapshot (runtimeSnapshots). + done (depId, depSnapshot) = + depId `Set.member` schedulerDone || + (depId, depSnapshot) `Set.member` schedulerSnapshots + + +-------------------------------------------------------------------------------- +schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int) +schedulerUnblock identifier scheduler@Scheduler {..} = + ( scheduler + { schedulerQueue = + schedulerQueue <> Seq.fromList (Set.toList triggered) + , schedulerStarved = 0 + , schedulerBlocked = Set.delete identifier $ + schedulerBlocked `Set.difference` triggered + , schedulerTriggers = Map.delete identifier schedulerTriggers + } + , schedulerStarved + ) + where + triggered = fromMaybe Set.empty $ Map.lookup identifier schedulerTriggers + + +-------------------------------------------------------------------------------- +schedulerSnapshot + :: Identifier -> Snapshot -> Compiler SomeItem + -> Scheduler -> (Scheduler, SchedulerStep) +schedulerSnapshot identifier snapshot compiler scheduler@Scheduler {..} = + let (scheduler', resume) = schedulerUnblock identifier scheduler + { schedulerSnapshots = + Set.insert (identifier, snapshot) schedulerSnapshots + } in + (scheduler', SchedulerWork identifier compiler resume) + + +-------------------------------------------------------------------------------- +schedulerWrite + :: Identifier + -> [Dependency] + -> Scheduler + -> (Scheduler, SchedulerStep) +schedulerWrite identifier depFacts scheduler0@Scheduler {..} = + let (scheduler1, resume) = schedulerUnblock identifier scheduler0 + { schedulerWorking = Set.delete identifier schedulerWorking + , schedulerFacts = Map.insert identifier depFacts schedulerFacts + , schedulerDone = + Set.insert identifier schedulerDone + , schedulerTodo = + Map.delete identifier schedulerTodo + } + (scheduler2, step) = schedulerPop scheduler1 in + case step of + SchedulerWork i c n -> (scheduler2, SchedulerWork i c (n + resume)) + _ -> (scheduler2, step) + + +-------------------------------------------------------------------------------- +build :: RunMode -> ReaderT RuntimeRead IO () build mode = do logger <- runtimeLogger <$> ask Logger.header logger "Checking for out-of-date items" + schedulerRef <- runtimeScheduler <$> ask scheduleOutOfDate case mode of RunModeNormal -> do Logger.header logger "Compiling" - pickAndChase + if rtsSupportsBoundThreads then pickAndChaseAsync else pickAndChase Logger.header logger "Success" - facts <- runtimeFacts <$> getRuntimeState + facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef store <- runtimeStore <$> ask liftIO $ Store.set store factsKey facts RunModePrintOutOfDate -> do Logger.header logger "Out of date items:" - todo <- runtimeTodo <$> getRuntimeState - traverse_ (Logger.message logger . show) (M.keys todo) + todo <- liftIO $ schedulerTodo <$> IORef.readIORef schedulerRef + traverse_ (Logger.message logger . show) (Map.keys todo) -------------------------------------------------------------------------------- -scheduleOutOfDate :: Runtime () +scheduleOutOfDate :: ReaderT RuntimeRead IO () scheduleOutOfDate = do - logger <- runtimeLogger <$> ask - provider <- runtimeProvider <$> ask - universe <- runtimeUniverse <$> ask - - let identifiers = M.keys universe - modified = S.filter (resourceModified provider) (M.keysSet universe) - - state <- getRuntimeState - let facts = runtimeFacts state - todo = runtimeTodo state - done = runtimeDone state - - let (ood, facts', msgs) = outOfDate identifiers modified facts - todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe - done' = done `S.union` (M.keysSet universe `S.difference` ood) + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + schedulerRef <- runtimeScheduler <$> ask + let modified = Set.filter (resourceModified provider) (Map.keysSet universe) + msgs <- liftIO . IORef.atomicModifyIORef' schedulerRef $ + schedulerMarkOutOfDate universe modified -- Print messages mapM_ (Logger.debug logger) msgs - -- Update facts and todo items - modifyRuntimeState $ \s -> s - { runtimeDone = done' - , runtimeTodo = todo `M.union` todo' - , runtimeFacts = facts' - } - -------------------------------------------------------------------------------- -pickAndChase :: Runtime () +pickAndChase :: ReaderT RuntimeRead IO () pickAndChase = do - todo <- runtimeTodo <$> getRuntimeState - unless (null todo) $ do - acted <- mconcat <$> forConcurrently (M.keys todo) chase - when (acted == Idled) $ do - -- This clause happens when chasing *every item* in `todo` resulted in - -- idling because tasks are all waiting on something: a dependency cycle - deps <- runtimeDependencies <$> getRuntimeState - throwError $ "Hakyll.Core.Runtime.pickAndChase: Dependency cycle detected: " ++ - intercalate ", " [show k ++ " depends on " ++ show (S.toList v) | (k, v) <- M.toList deps] - pickAndChase + scheduler <- runtimeScheduler <$> ask + let go SchedulerFinish = pure () + go SchedulerError = pure () + go (SchedulerWork i c _) = work i c >>= go + go SchedulerStarve = + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerError Nothing "Starved, possible dependency cycle?" + pop <- liftIO . IORef.atomicModifyIORef' scheduler $ schedulerPop + go pop -------------------------------------------------------------------------------- --- | Tracks whether a set of tasks has progressed overall (at least one task progressed) --- or has idled -data Progress = Progressed | Idled deriving (Eq) +pickAndChaseAsync :: ReaderT RuntimeRead IO () +pickAndChaseAsync = do + runtimeRead <- ask + numThreads <- liftIO getNumCapabilities + let scheduler = runtimeScheduler runtimeRead + Logger.message (runtimeLogger runtimeRead) $ + "Using async runtime with " <> show numThreads <> " threads..." + liftIO $ do + signal <- MVar.newEmptyMVar -instance Semigroup Progress where - Idled <> Idled = Idled - Progressed <> _ = Progressed - _ <> Progressed = Progressed + let spawnN :: Int -> IO () + spawnN n = replicateM_ n $ forkIO $ + IORef.atomicModifyIORef' scheduler schedulerPop >>= go -instance Monoid Progress where - mempty = Idled + go :: SchedulerStep -> IO () + go step = case step of + SchedulerFinish -> void $ MVar.tryPutMVar signal () + SchedulerStarve -> pure () + SchedulerError -> void $ MVar.tryPutMVar signal () + (SchedulerWork i c n) -> do + spawnN n + step' <- runReaderT (work i c) runtimeRead + go step' + spawnN numThreads + MVar.readMVar signal + -------------------------------------------------------------------------------- -chase :: Identifier -> Runtime Progress -chase id' = do +work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep +work id' compiler = do logger <- runtimeLogger <$> ask provider <- runtimeProvider <$> ask universe <- runtimeUniverse <$> ask routes <- runtimeRoutes <$> ask store <- runtimeStore <$> ask config <- runtimeConfiguration <$> ask - - state <- getRuntimeState - - Logger.debug logger $ "Processing " ++ show id' + scheduler <- runtimeScheduler <$> ask - let compiler = (runtimeTodo state) M.! id' - read' = CompilerRead + let cread = CompilerRead { compilerConfig = config , compilerUnderlying = id' , compilerProvider = provider - , compilerUniverse = M.keysSet universe + , compilerUniverse = Map.keysSet universe , compilerRoutes = routes , compilerStore = store , compilerLogger = logger } - - result <- liftIO $ runCompiler compiler read' + result <- liftIO $ runCompiler compiler cread 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) - } - - return Progressed + CompilerError e -> do + let msgs = case compilerErrorMessages e of + [] -> ["Compiler failed but no info given, try running with -v?"] + es -> es + for_ msgs $ \msg -> liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerError (Just id') msg + return SchedulerError + CompilerSnapshot snapshot c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerSnapshot id' snapshot c - -- Huge success CompilerDone (SomeItem item) cwrite -> do -- Print some info let facts = compilerDependencies cwrite @@ -277,11 +466,13 @@ 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)" + liftIO . unless (itemIdentifier item == id') $ + IORef.atomicModifyIORef' scheduler $ schedulerError + (Just id') $ + "The compiler yielded an Item with Identifier " ++ + show (itemIdentifier item) ++ ", but we were expecting " ++ + "an Item with Identifier " ++ show id' ++ " " ++ + "(you probably want to call makeItem to solve this problem)" -- Write if necessary (mroute, _) <- liftIO $ runRoutes routes provider id' @@ -293,51 +484,10 @@ liftIO $ write path item Logger.debug logger $ "Routed to " ++ path - -- 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) - , runtimeDependencies = M.delete id' (runtimeDependencies s) - } - - return Progressed - - -- Try something else first - CompilerRequire reqs c -> do - let done = runtimeDone state - snapshots = runtimeSnapshots state - - deps <- fmap join . for reqs $ \(depId, depSnapshot) -> do - Logger.debug logger $ - "Compiler requirement found for: " ++ show id' ++ - ": " ++ show depId ++ " (snapshot " ++ depSnapshot ++ ")" - - -- 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 - actualDep = [(depId, depSnapshot) | not depDone] - - return actualDep - - modifyRuntimeState $ \s -> s - { runtimeTodo = M.insert id' - (if null deps then c else compilerResult result) - (runtimeTodo s) - -- We track dependencies only to inform users when an infinite loop is detected - , runtimeDependencies = M.insertWith S.union id' (S.fromList deps) (runtimeDependencies s) - } - - -- Progress has been made if at least one of the - -- requirements can move forwards at the next pass - -- In some cases, dependencies have been processed in parallel in which case `deps` - -- can be empty, and we can progress to the next stage. See issue #907 - let progress | null deps = Progressed - | deps == reqs = Idled - | otherwise = Progressed + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerWrite id' facts - return progress + CompilerRequire reqs c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerBlock id' reqs c diff --git a/lib/Hakyll/Web/Feed.hs b/lib/Hakyll/Web/Feed.hs --- a/lib/Hakyll/Web/Feed.hs +++ b/lib/Hakyll/Web/Feed.hs @@ -23,8 +23,10 @@ ( FeedConfiguration (..) , renderRss , renderAtom + , renderJson , renderRssWithTemplates , renderAtomWithTemplates + , renderJsonWithTemplates ) where @@ -40,6 +42,7 @@ -------------------------------------------------------------------------------- import Data.FileEmbed (makeRelativeToProject) import System.FilePath (()) +import Text.Printf (printf) -------------------------------------------------------------------------------- @@ -63,7 +66,17 @@ $(makeRelativeToProject ("data" "templates" "atom-item.xml") >>= embedTemplate) +jsonTemplate :: Template +jsonTemplate = + $(makeRelativeToProject ("data" "templates" "feed.json") + >>= embedTemplate) +jsonItemTemplate :: Template +jsonItemTemplate = + $(makeRelativeToProject ("data" "templates" "feed-item.json") + >>= embedTemplate) + + -------------------------------------------------------------------------------- -- | This is a data structure to keep the configuration of a feed. data FeedConfiguration = FeedConfiguration @@ -82,16 +95,30 @@ -------------------------------------------------------------------------------- +-- | Different types a feed can have. +data FeedType = XmlFeed | JsonFeed + deriving (Show, Eq) + + +-------------------------------------------------------------------------------- -- | Abstract function to render any feed. -renderFeed :: Template -- ^ Default feed template +renderFeed :: FeedType -- ^ Feed type + -> Template -- ^ Default feed template -> Template -- ^ Default item template -> FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Context for the items -> [Item String] -- ^ Input items -> Compiler (Item String) -- ^ Resulting item -renderFeed feedTpl itemTpl config itemContext items = do - protectedItems <- mapM (applyFilter protectCDATA) items - body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems +renderFeed feedType feedTpl itemTpl config itemContext items = do + protectedItems <- + case feedType of + XmlFeed -> mapM (applyFilter protectCDATA) items + JsonFeed -> pure items + let itemDelim = case feedType of + XmlFeed -> "" + JsonFeed -> ", " + + body <- makeItem =<< applyJoinTemplateList itemDelim itemTpl itemContext' protectedItems applyTemplate feedTpl feedContext body where applyFilter :: (Monad m,Functor f) => (String -> String) -> f String -> m (f String) @@ -100,7 +127,7 @@ protectCDATA = replaceAll "]]>" (const "]]>") itemContext' = mconcat - [ itemContext + [ escapeDescription itemContext , constField "root" (feedRoot config) , constField "authorName" (feedAuthorName config) , emailField @@ -130,6 +157,10 @@ "" -> missingField email -> constField "authorEmail" email + escapeDescription = case feedType of + XmlFeed -> id + JsonFeed -> mapContextBy (== "description") escapeString + -------------------------------------------------------------------------------- -- | Render an RSS feed using given templates with a number of items. renderRssWithTemplates :: @@ -140,7 +171,7 @@ -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed renderRssWithTemplates feedTemplate itemTemplate config context = renderFeed - feedTemplate itemTemplate config + XmlFeed feedTemplate itemTemplate config (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context) @@ -154,11 +185,25 @@ -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed renderAtomWithTemplates feedTemplate itemTemplate config context = renderFeed - feedTemplate itemTemplate config + XmlFeed feedTemplate itemTemplate config (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context) -------------------------------------------------------------------------------- +-- | Render a JSON feed using given templates with a number of items. +renderJsonWithTemplates :: + Template -- ^ Feed template + -> Template -- ^ Item template + -> FeedConfiguration -- ^ Feed configuration + -> Context String -- ^ Item context + -> [Item String] -- ^ Feed items + -> Compiler (Item String) -- ^ Resulting feed +renderJsonWithTemplates feedTemplate itemTemplate config context = renderFeed + JsonFeed feedTemplate itemTemplate config + (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context) + + +-------------------------------------------------------------------------------- -- | Render an RSS feed with a number of items. renderRss :: FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Item context @@ -177,7 +222,40 @@ -------------------------------------------------------------------------------- +-- | Render a JSON feed with a number of items. +-- +-- Items' bodies will be put into @content_html@ field of the resulting JSON; +-- the @content@ field will not be set. +renderJson :: FeedConfiguration -- ^ Feed configuration + -> Context String -- ^ Item context + -> [Item String] -- ^ Feed items + -> Compiler (Item String) -- ^ Resulting feed +renderJson = renderJsonWithTemplates jsonTemplate jsonItemTemplate + + +-------------------------------------------------------------------------------- -- | Copies @$updated$@ from @$published$@ if it is not already set. makeItemContext :: String -> Context a -> Context a makeItemContext fmt context = mconcat [context, dateField "published" fmt, dateField "updated" fmt] + + +-------------------------------------------------------------------------------- +-- | Escape the string according to [RFC8259 §7](https://www.rfc-editor.org/rfc/rfc8259#section-7). In other words, +-- * quotation marks and backslashes are prefixed with a backslash +-- * control characters (i.e. 0x00 - 0x1F) are escaped s.t. their +-- hex representation are prefixed with "\u00" (e.g. 0x15 -> \u0015) +-- * the rest of the characters are untouched. +escapeString :: String -> String +escapeString = flip escapeString' "" + where + escapeString' :: String -> ShowS + escapeString' [] s = s + escapeString' ('"' : cs) s = showString "\\\"" (escapeString' cs s) + escapeString' ('\\' : cs) s = showString "\\\\" (escapeString' cs s) + escapeString' (c : cs) s + | c < ' ' = escapeChar c (escapeString' cs s) + | otherwise = showChar c (escapeString' cs s) + + escapeChar :: Char -> ShowS + escapeChar = showString . printf "\\u%04X" diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs --- a/lib/Hakyll/Web/Template/Context.hs +++ b/lib/Hakyll/Web/Template/Context.hs @@ -31,6 +31,7 @@ , listFieldWith , functionField , mapContext + , mapContextBy , defaultContext , bodyField @@ -201,11 +202,26 @@ -- > constField "x" "ac" <> constField "y" "bc" -- mapContext :: (String -> String) -> Context a -> Context a -mapContext f (Context c) = Context $ \k a i -> do +mapContext = mapContextBy (const True) + + +-------------------------------------------------------------------------------- +-- | Transform the respective string results of all fields in a context +-- satisfying a predicate. For example, +-- +-- > mapContextBy (=="y") (++"c") (constField "x" "a" <> constField "y" "b") +-- +-- is equivalent to +-- +-- > constField "x" "a" <> constField "y" "bc" +-- +mapContextBy :: (String -> Bool) -> (String -> String) -> Context a -> Context a +mapContextBy p f (Context c) = Context $ \k a i -> do fld <- c k a i case fld of EmptyField -> wrongType "boolField" - StringField str -> return $ StringField (f str) + StringField str -> return $ StringField $ + if p k then f str else str _ -> wrongType "ListField" where wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++ 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,8 +8,9 @@ -------------------------------------------------------------------------------- import Control.Monad (void) import qualified Data.ByteString as B -import System.FilePath (()) +import Data.List (isInfixOf) import System.Exit (ExitCode (..)) +import System.FilePath (()) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, (@?=)) @@ -102,7 +103,7 @@ -- Test that dependency cycles are correctly identified case03 :: Assertion case03 = do - logger <- Logger.new Logger.Error + (logger, inMemLog) <- Logger.newInMem (ec, _) <- run RunModeNormal testConfiguration logger $ do create ["partial.html.out1"] $ do @@ -119,19 +120,23 @@ makeItem example >>= loadAndApplyTemplate "partial.html" defaultContext - ec @?= ExitFailure 1 + msgs <- inMemLog + length + [ msg + | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg + ] @?= 1 cleanTestEnv -------------------------------------------------------------------------------- --- Test that dependency cycles are correctly identified when snapshots +-- Test that dependency cycles are correctly identified when snapshots -- are also involved. See issue #878. case04 :: Assertion case04 = do - logger <- Logger.new Logger.Error - (ec, _) <- run RunModeNormal testConfiguration logger $ do + (logger, inMemLog) <- Logger.newInMem + (ec, _) <- run RunModeNormal testConfiguration logger $ do create ["partial.html.out1"] $ do route idRoute @@ -148,16 +153,21 @@ >>= loadAndApplyTemplate "partial.html" defaultContext ec @?= ExitFailure 1 + msgs <- inMemLog + length + [ msg + | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg + ] @?= 1 cleanTestEnv -------------------------------------------------------------------------------- --- Test that dependency cycles are correctly identified in the presence of +-- Test that dependency cycles are correctly identified in the presence of -- snapshots. See issue #878. -case05 :: Assertion +case05 :: Assertion case05 = do - logger <- Logger.new Logger.Error + logger <- Logger.new Logger.Error (ec, _) <- run RunModeNormal testConfiguration logger $ do match "posts/*" $ do @@ -185,18 +195,18 @@ makeItem "" >>= loadAndApplyTemplate "template-empty.html" footerCtx - + create ["template-empty.html"] $ compile templateCompiler - ec @?= ExitSuccess + ec @?= ExitSuccess cleanTestEnv -------------------------------------------------------------------------------- --- Test that dependency cycles are correctly identified in the presence of +-- Test that dependency cycles are correctly identified in the presence of -- snapshots. The test case below was presented as an example which invalidated --- a previous approach to dependency cycle checking. +-- a previous approach to dependency cycle checking. -- See https://github.com/jaspervdj/hakyll/pull/880#discussion_r708650172 case06 :: Assertion case06 = do diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs --- a/tests/TestSuite/Util.hs +++ b/tests/TestSuite/Util.hs @@ -38,7 +38,7 @@ -> [Assertion] -- ^ Cases -> [TestTree] -- ^ Result tests fromAssertions name = - zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]] + zipWith testCase [printf "%02d_%s" n name | n <- [1 :: Int ..]] --------------------------------------------------------------------------------