hakyll 4.16.0.0 → 4.16.1.0

raw patch · 10 files changed

+534/−242 lines, 10 filesdep −lifted-asyncPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: lifted-async

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• data/templates/feed-item.json +8/−0
• data/templates/feed.json +17/−0
• hakyll.cabal +6/−5
• lib/Hakyll/Core/Logger.hs +41/−37
• lib/Hakyll/Core/Runtime.hs +327/−177
• lib/Hakyll/Web/Feed.hs +85/−7
• lib/Hakyll/Web/Template/Context.hs +18/−2
• tests/Hakyll/Core/Runtime/Tests.hs +23/−13
• tests/TestSuite/Util.hs +1/−1

@@ -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

@@ -0,0 +1,8 @@+{+    "id": "$root$$url$",+    "url": "$root$$url$",+    "content_html": "$description$",+    "title": "$title$",+    "date_published": "$published$",+    "date_modified": "$updated$"+}

@@ -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$ ]+}

@@ -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,

@@ -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+        )

@@ -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

@@ -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 "]]&gt;")      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"

@@ -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: " ++

@@ -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

@@ -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 ..]]   --------------------------------------------------------------------------------