From fa929d0c9bef4d683a525b9dfe5d3f8d5dcc1b0a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Jan 2013 11:08:10 +0100 Subject: Export the Tags datatype constructor --- src/Hakyll/Web/Tags.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index 4566db6..edb21ed 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -41,7 +41,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Tags - ( Tags + ( Tags (..) , getTags , buildTagsWith , buildTags -- cgit v1.2.3 From d6fa74c54a8500d11e95e3d8822d47a56460a9da Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Jan 2013 11:15:14 +0100 Subject: Export renderTags as well --- hakyll.cabal | 2 +- src/Hakyll/Web/Tags.hs | 11 ++++------- web/releases.markdown | 6 ++++++ 3 files changed, 11 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index a3a75cd..2d0a47d 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 4.1.3.0 +Version: 4.1.4.0 Synopsis: A static website compiler library Description: diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index edb21ed..fe99e3c 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -47,6 +47,7 @@ module Hakyll.Web.Tags , buildTags , buildCategories , tagsRules + , renderTags , renderTagCloud , renderTagList , tagsField @@ -149,7 +150,7 @@ tagsRules tags rules = -------------------------------------------------------------------------------- --- | Render tags in HTML +-- | Render tags in HTML (the flexible higher-order function) renderTags :: (String -> String -> Int -> Int -> Int -> String) -- ^ Produce a tag item: tag, url, count, min count, max count -> ([String] -> String) @@ -218,13 +219,9 @@ renderTagList = renderTags makeLink (intercalate ", ") -------------------------------------------------------------------------------- --- | Render tags with links with custom function to get tags. It is typically --- together with 'getTags' like this: --- --- > renderTagsFieldWith (customFunction . getTags) --- > "tags" (fromCapture "tags/*") +-- | Render tags with links with custom function to get tags tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags - -> String -- ^ Destination key + -> String -- ^ Destination field -> Tags -- ^ Tags structure -> Context a -- ^ Resulting context tagsFieldWith getTags' key tags = field key $ \item -> do diff --git a/web/releases.markdown b/web/releases.markdown index ab77c62..f771070 100644 --- a/web/releases.markdown +++ b/web/releases.markdown @@ -4,6 +4,12 @@ title: Releases # Releases +## Hakyll 4.1.4.0 + +*January 26, 2013* + +- Export the flexible `renderTags` function + ## Hakyll 4.1.3.0 *January 26, 2013* -- cgit v1.2.3 From d2d52133f6815b1f1516c98c156bbe1abd2b559b Mon Sep 17 00:00:00 2001 From: Alexander Vershilov Date: Mon, 28 Jan 2013 11:29:43 +0400 Subject: Read second extension to find our inner .lhs format .md.lhs -> will be read as markdown + lhs .tex.lhs -> will be read as latex +lhs markdown format is default --- src/Hakyll/Web/Pandoc/FileType.hs | 40 +++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs index 1ae4c10..28698a7 100644 --- a/src/Hakyll/Web/Pandoc/FileType.hs +++ b/src/Hakyll/Web/Pandoc/FileType.hs @@ -36,27 +36,27 @@ data FileType -------------------------------------------------------------------------------- -- | Get the file type for a certain file. The type is determined by extension. fileType :: FilePath -> FileType -fileType = fileType' . takeExtension +fileType = uncurry fileType' . splitExtension where - fileType' ".css" = Css - fileType' ".htm" = Html - fileType' ".html" = Html - fileType' ".lhs" = LiterateHaskell Markdown - fileType' ".markdown" = Markdown - fileType' ".md" = Markdown - fileType' ".mdn" = Markdown - fileType' ".mdown" = Markdown - fileType' ".mdwn" = Markdown - fileType' ".mkd" = Markdown - fileType' ".mkdwn" = Markdown - fileType' ".org" = OrgMode - fileType' ".page" = Markdown - fileType' ".rst" = Rst - fileType' ".tex" = LaTeX - fileType' ".text" = PlainText - fileType' ".textile" = Textile - fileType' ".txt" = PlainText - fileType' _ = Binary -- Treat unknown files as binary + fileType' _ ".css" = Css + fileType' _ ".htm" = Html + fileType' _ ".html" = Html + fileType' f ".lhs" = LiterateHaskell (fileType' (takeExtension f)) + fileType' _ ".markdown" = Markdown + fileType' _ ".md" = Markdown + fileType' _ ".mdn" = Markdown + fileType' _ ".mdown" = Markdown + fileType' _ ".mdwn" = Markdown + fileType' _ ".mkd" = Markdown + fileType' _ ".mkdwn" = Markdown + fileType' _ ".org" = OrgMode + fileType' _ ".page" = Markdown + fileType' _ ".rst" = Rst + fileType' _ ".tex" = LaTeX + fileType' _ ".text" = PlainText + fileType' _ ".textile" = Textile + fileType' _ ".txt" = PlainText + fileType' _ _ = Binary -- Treat unknown files as binary -------------------------------------------------------------------------------- -- cgit v1.2.3 From eaa190f1e3029573a4bf4ecf238d3b8c236ad4fa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 28 Jan 2013 11:36:59 +0100 Subject: Fix .tex.lhs patch, add some test cases --- src/Hakyll/Web/Pandoc/FileType.hs | 10 +++++++--- tests/Hakyll/Web/Pandoc/FileType/Tests.hs | 26 ++++++++++++++++++++++++++ tests/TestSuite.hs | 2 ++ 3 files changed, 35 insertions(+), 3 deletions(-) create mode 100644 tests/Hakyll/Web/Pandoc/FileType/Tests.hs (limited to 'src') diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs index 28698a7..46c8e24 100644 --- a/src/Hakyll/Web/Pandoc/FileType.hs +++ b/src/Hakyll/Web/Pandoc/FileType.hs @@ -8,7 +8,7 @@ module Hakyll.Web.Pandoc.FileType -------------------------------------------------------------------------------- -import System.FilePath (takeExtension) +import System.FilePath (splitExtension) -------------------------------------------------------------------------------- @@ -36,12 +36,16 @@ data FileType -------------------------------------------------------------------------------- -- | Get the file type for a certain file. The type is determined by extension. fileType :: FilePath -> FileType -fileType = uncurry fileType' . splitExtension +fileType = uncurry fileType' . splitExtension where fileType' _ ".css" = Css fileType' _ ".htm" = Html fileType' _ ".html" = Html - fileType' f ".lhs" = LiterateHaskell (fileType' (takeExtension f)) + fileType' f ".lhs" = LiterateHaskell $ case fileType f of + -- If no extension is given, default to Markdown + LiterateHaskell + Binary -> Markdown + -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified + x -> x fileType' _ ".markdown" = Markdown fileType' _ ".md" = Markdown fileType' _ ".mdn" = Markdown diff --git a/tests/Hakyll/Web/Pandoc/FileType/Tests.hs b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs new file mode 100644 index 0000000..e6b222f --- /dev/null +++ b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs @@ -0,0 +1,26 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Pandoc.FileType.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import Hakyll.Web.Pandoc.FileType +import TestSuite.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $ + fromAssertions "fileType" + [ Markdown @=? fileType "index.md" + , Rst @=? fileType "about/foo.rst" + , LiterateHaskell Markdown @=? fileType "posts/bananas.lhs" + , LiterateHaskell LaTeX @=? fileType "posts/bananas.tex.lhs" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 9be857c..7c913dd 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -20,6 +20,7 @@ import qualified Hakyll.Core.UnixFilter.Tests import qualified Hakyll.Core.Util.String.Tests import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests +import qualified Hakyll.Web.Pandoc.FileType.Tests import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests @@ -38,6 +39,7 @@ main = defaultMain , Hakyll.Core.Util.String.Tests.tests , Hakyll.Web.Html.RelativizeUrls.Tests.tests , Hakyll.Web.Html.Tests.tests + , Hakyll.Web.Pandoc.FileType.Tests.tests , Hakyll.Web.Template.Context.Tests.tests , Hakyll.Web.Template.Tests.tests ] -- cgit v1.2.3 From 8d8392ebdf9ac37fbb05aa329e30c9074e5b4c6a Mon Sep 17 00:00:00 2001 From: Miikka Koskinen Date: Sat, 2 Feb 2013 19:04:48 +0200 Subject: Fix unixFilterLBS example to use unixFilterLBS --- src/Hakyll/Core/UnixFilter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs index 2a2f394..261613d 100644 --- a/src/Hakyll/Core/UnixFilter.hs +++ b/src/Hakyll/Core/UnixFilter.hs @@ -57,7 +57,7 @@ unixFilter = unixFilterWith writer reader -- -- > match "music.wav" $ do -- > route $ setExtension "ogg" --- > compile $ getResourceLBS >>= withItemBody (unixFilter "oggenc" ["-"]) +-- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"]) unixFilterLBS :: String -- ^ Program name -> [String] -- ^ Program args -> ByteString -- ^ Program input -- cgit v1.2.3 From 603e1c20c3eea9091f618ce72e6dc3b633535826 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 2 Feb 2013 21:55:57 +0100 Subject: Bail when different compilers for the same id --- src/Hakyll/Core/Rules/Internal.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 10ca919..09d9b1e 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -16,9 +16,9 @@ import Control.Applicative (Applicative, (<$>)) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.Trans (liftIO) -import qualified Data.Map as M import Data.Monoid (Monoid, mappend, mempty) import Data.Set (Set) +import qualified Data.Set as S -------------------------------------------------------------------------------- @@ -92,7 +92,12 @@ instance MonadMetadata Rules where runRules :: Rules a -> Provider -> IO RuleSet runRules rules provider = do (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState - return $ nubCompilers ruleSet + case findDuplicate (map fst $ rulesCompilers ruleSet) of + Nothing -> return ruleSet + Just id' -> error $ + "Hakyll.Core.Rules.Internal: two different rules for " ++ + show id' ++ " exist, bailing out" + where env = RulesRead { rulesProvider = provider @@ -102,9 +107,10 @@ runRules rules provider = do -------------------------------------------------------------------------------- --- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an --- item, we prefer the first one -nubCompilers :: RuleSet -> RuleSet -nubCompilers set = set {rulesCompilers = nubCompilers' (rulesCompilers set)} +findDuplicate :: Ord a => [a] -> Maybe a +findDuplicate = go S.empty where - nubCompilers' = M.toList . M.fromListWith (flip const) + go _ [] = Nothing + go s (x : xs) + | x `S.member` s = Just x + | otherwise = go (S.insert x s) xs -- cgit v1.2.3 From d34d56b10e14e41ad303e6c5d3daef6970af65c2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 6 Feb 2013 20:50:44 +0100 Subject: Use mtime instead of hashing files, much faster --- src/Hakyll/Core/Provider/Modified.hs | 58 ++++++++++++++++++++++-------------- src/Hakyll/Core/Store.hs | 8 +++++ 2 files changed, 44 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Provider/Modified.hs b/src/Hakyll/Core/Provider/Modified.hs index 8fad96a..4c3bdc5 100644 --- a/src/Hakyll/Core/Provider/Modified.hs +++ b/src/Hakyll/Core/Provider/Modified.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Core.Provider.Modified ( resourceModified , resourceModificationTime @@ -9,12 +10,12 @@ module Hakyll.Core.Provider.Modified -------------------------------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.Monad (when) -import qualified Crypto.Hash.MD5 as MD5 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import Data.Binary (Binary (..)) import Data.IORef import qualified Data.Map as M -import Data.Time (UTCTime) +import Data.Time (Day (..), UTCTime (..), + secondsToDiffTime) +import Data.Typeable (Typeable) import System.Directory (getModificationTime) @@ -48,7 +49,7 @@ resourceModified p r -- Check if the actual file was modified, and do a recursive -- call to check if the metadata file was modified m <- (||) - <$> fileDigestModified store filePath + <$> fileModified store filePath <*> resourceModified p (resourceMetadataResource r) modifyIORef cacheRef (M.insert normalized m) @@ -65,37 +66,50 @@ resourceModified p r -------------------------------------------------------------------------------- --- | Utility: Check if a the digest of a file was modified -fileDigestModified :: Store -> FilePath -> IO Bool -fileDigestModified store fp = do - -- Get the latest seen digest from the store, and calculate the current - -- digest for the - lastDigest <- Store.get store key - newDigest <- fileDigest fp - if Store.Found newDigest == lastDigest +-- | Utility: Check if a file was modified recently +fileModified :: Store -> FilePath -> IO Bool +fileModified store fp = do + lastModified <- Store.get store key + newModified <- BinaryTime <$> fileModificationTime fp + if maybe False (>= newModified) (Store.toMaybe lastModified) -- All is fine, not modified then return False -- Resource modified; store new digest else do - Store.set store key newDigest + Store.set store key newModified return True where key = ["Hakyll.Core.Resource.Provider.fileModified", fp] -------------------------------------------------------------------------------- --- | Utility: Retrieve a digest for a given file -fileDigest :: FilePath -> IO B.ByteString -fileDigest = fmap MD5.hashlazy . BL.readFile +resourceModificationTime :: Provider -> Identifier -> IO UTCTime +resourceModificationTime p i = fileModificationTime $ resourceFilePath p i -------------------------------------------------------------------------------- -resourceModificationTime :: Provider -> Identifier -> IO UTCTime -resourceModificationTime p i = do +fileModificationTime :: FilePath -> IO UTCTime +fileModificationTime fp = do #if MIN_VERSION_directory(1,2,0) - getModificationTime $ resourceFilePath p i + getModificationTime fp #else - ct <- toCalendarTime =<< getModificationTime (resourceFilePath p i) + ct <- toCalendarTime =<< getModificationTime fp let str = formatCalendarTime defaultTimeLocale "%s" ct return $ readTime defaultTimeLocale "%s" str #endif + + +-------------------------------------------------------------------------------- +-- | Because UTCTime doesn't have a Binary instance... +newtype BinaryTime = BinaryTime UTCTime + deriving (Eq, Ord, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary BinaryTime where + put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) = + put d >> put (floor dt :: Integer) + + get = fmap BinaryTime $ UTCTime + <$> (ModifiedJulianDay <$> get) + <*> (secondsToDiffTime <$> get) diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs index 63dd64c..e3bcce3 100644 --- a/src/Hakyll/Core/Store.hs +++ b/src/Hakyll/Core/Store.hs @@ -5,6 +5,7 @@ module Hakyll.Core.Store ( Store , Result (..) + , toMaybe , new , set , get @@ -53,6 +54,13 @@ data Result a deriving (Show, Eq) +-------------------------------------------------------------------------------- +-- | Convert result to 'Maybe' +toMaybe :: Result a -> Maybe a +toMaybe (Found x) = Just x +toMaybe _ = Nothing + + -------------------------------------------------------------------------------- -- | Initialize the store new :: Bool -- ^ Use in-memory caching -- cgit v1.2.3 From ea953d3415232ba53aadc061e9005dbe74e3b012 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 6 Feb 2013 22:40:18 +0100 Subject: Ignore files sooner, small speedup --- src/Hakyll/Check.hs | 3 ++- src/Hakyll/Core/Configuration.hs | 2 +- src/Hakyll/Core/Provider/Internal.hs | 3 +-- src/Hakyll/Core/Util/File.hs | 11 ++++++----- src/Hakyll/Init.hs | 2 +- 5 files changed, 11 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Check.hs b/src/Hakyll/Check.hs index 6b9918b..5f8f4f7 100644 --- a/src/Hakyll/Check.hs +++ b/src/Hakyll/Check.hs @@ -94,7 +94,8 @@ runChecker checker config verbosity check' = do checkDestination :: Checker () checkDestination = do config <- checkerConfig <$> ask - files <- liftIO $ getRecursiveContents (destinationDirectory config) + files <- liftIO $ + getRecursiveContents (const False) (destinationDirectory config) let htmls = [ destinationDirectory config file diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs index 47de700..fdca879 100644 --- a/src/Hakyll/Core/Configuration.hs +++ b/src/Hakyll/Core/Configuration.hs @@ -37,7 +37,7 @@ data Configuration = Configuration -- -- Note that the files in 'destinationDirectory' and 'storeDirectory' will -- also be ignored. Note that this is the configuration parameter, if you - -- want to use the test, you should use 'shouldIgnoreFile'. + -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs index 1360ef5..301c25c 100644 --- a/src/Hakyll/Core/Provider/Internal.hs +++ b/src/Hakyll/Core/Provider/Internal.hs @@ -51,8 +51,7 @@ newProvider :: Store -- ^ Store to use -> FilePath -- ^ Search directory -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do - list <- map fromFilePath . filter (not . ignore) <$> - getRecursiveContents directory + list <- map fromFilePath <$> getRecursiveContents ignore directory cache <- newIORef M.empty return $ Provider directory (S.fromList list) cache store diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 0e34d7c..20cfbbc 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -25,12 +25,13 @@ makeDirectories = createDirectoryIfMissing True . takeDirectory -------------------------------------------------------------------------------- -- | Get all contents of a directory. -getRecursiveContents :: FilePath -- ^ Directory to search - -> IO [FilePath] -- ^ List of files found -getRecursiveContents top = go "" +getRecursiveContents :: (FilePath -> Bool) -- ^ Ignore this file/directory + -> FilePath -- ^ Directory to search + -> IO [FilePath] -- ^ List of files found +getRecursiveContents ignore top = go "" where - isProper = (`notElem` [".", ".."]) - go dir = do + isProper x = notElem x [".", ".."] && not (ignore x) + go dir = do dirExists <- doesDirectoryExist (top dir) if not dirExists then return [] diff --git a/src/Hakyll/Init.hs b/src/Hakyll/Init.hs index 3e2969e..2a92340 100644 --- a/src/Hakyll/Init.hs +++ b/src/Hakyll/Init.hs @@ -23,7 +23,7 @@ main = do progName <- getProgName args <- getArgs srcDir <- getDataFileName "example" - files <- getRecursiveContents srcDir + files <- getRecursiveContents (const False) srcDir case args of [dstDir] -> forM_ files $ \file -> do -- cgit v1.2.3 From 86d0b68aed6e82fd4a6c935ce6113937023f6e6b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 9 Feb 2013 15:11:40 +0100 Subject: Start provider rewrite --- hakyll.cabal | 1 - src/Hakyll/Core/Compiler.hs | 2 +- src/Hakyll/Core/Provider.hs | 51 +++++----- src/Hakyll/Core/Provider/Internal.hs | 155 +++++++++++++++++++++++++----- src/Hakyll/Core/Provider/Metadata.hs | 7 +- src/Hakyll/Core/Provider/MetadataCache.hs | 1 + src/Hakyll/Core/Provider/Modified.hs | 115 ---------------------- src/Hakyll/Core/Runtime.hs | 7 +- src/Hakyll/Web/Template/Context.hs | 3 +- tests/Hakyll/Core/Provider/Tests.hs | 1 + tests/Hakyll/Core/Rules/Tests.hs | 1 + tests/Hakyll/Core/Store/Tests.hs | 1 + tests/Hakyll/Web/Template/Tests.hs | 2 + 13 files changed, 173 insertions(+), 174 deletions(-) delete mode 100644 src/Hakyll/Core/Provider/Modified.hs (limited to 'src') diff --git a/hakyll.cabal b/hakyll.cabal index 2d0a47d..c143929 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -151,7 +151,6 @@ Library Hakyll.Core.Provider.Internal Hakyll.Core.Provider.Metadata Hakyll.Core.Provider.MetadataCache - Hakyll.Core.Provider.Modified Hakyll.Core.Rules.Internal Hakyll.Core.Runtime Hakyll.Core.Store diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index dcaf2f0..b23b69b 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -131,7 +131,7 @@ cached name compiler = do id' <- compilerUnderlying <$> compilerAsk store <- compilerStore <$> compilerAsk provider <- compilerProvider <$> compilerAsk - modified <- compilerUnsafeIO $ resourceModified provider id' + let modified = resourceModified provider id' if modified then do x <- compiler diff --git a/src/Hakyll/Core/Provider.hs b/src/Hakyll/Core/Provider.hs index 64b3786..4dd8288 100644 --- a/src/Hakyll/Core/Provider.hs +++ b/src/Hakyll/Core/Provider.hs @@ -3,44 +3,43 @@ -- caching. module Hakyll.Core.Provider ( -- * Constructing resource providers - Provider + Internal.Provider , newProvider -- * Querying resource properties - , resourceList - , resourceExists - , resourceModified - , resourceModificationTime + , Internal.resourceList + , Internal.resourceExists + , Internal.resourceModified + , Internal.resourceModificationTime -- * Access to raw resource content - , resourceString - , resourceLBS + , Internal.resourceString + , Internal.resourceLBS -- * Access to metadata and body content - , resourceMetadata - , resourceBody + , Internal.resourceMetadata + , Internal.resourceBody ) where -------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Metadata -import Hakyll.Core.Provider.Internal +import Control.Monad (forM_) +import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal -import Hakyll.Core.Provider.Modified +import Hakyll.Core.Store (Store) -------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceMetadata :: Provider -> Identifier -> IO Metadata -resourceMetadata rp r = do - _ <- resourceModified rp r - Internal.resourceMetadata rp r - - --------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceBody :: Provider -> Identifier -> IO String -resourceBody rp r = do - _ <- resourceModified rp r - Internal.resourceBody rp r +-- | Create a resource provider +newProvider :: Store -- ^ Store to use + -> (FilePath -> Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO Internal.Provider -- ^ Resulting provider +newProvider store ignore directory = do + -- Delete metadata cache where necessary + provider <- Internal.newProvider store ignore directory + forM_ (Internal.resourceList provider) $ \identifier -> + if Internal.resourceModified provider identifier + then Internal.resourceInvalidateMetadataCache provider identifier + else return () + return provider diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs index 301c25c..64b19c8 100644 --- a/src/Hakyll/Core/Provider/Internal.hs +++ b/src/Hakyll/Core/Provider/Internal.hs @@ -1,46 +1,103 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Provider.Internal - ( Provider (..) + ( ResourceInfo (..) + , Provider (..) , newProvider , resourceList , resourceExists - , resourceMetadataResource , resourceFilePath , resourceString , resourceLBS + + , resourceModified + , resourceModificationTime ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) +import Control.DeepSeq (NFData (..), deepseq) +import Control.Monad (forM) +import Data.Binary (Binary (..)) import qualified Data.ByteString.Lazy as BL -import Data.IORef import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty) import Data.Set (Set) import qualified Data.Set as S +import Data.Time (Day (..), UTCTime (..), + secondsToDiffTime) +import Data.Typeable (Typeable) +import System.Directory (getModificationTime) import System.FilePath (addExtension, ()) +-------------------------------------------------------------------------------- +#if !MIN_VERSION_directory(1,2,0) +import Data.Time (readTime) +import System.Locale (defaultTimeLocale) +import System.Time (formatCalendarTime, toCalendarTime) +#endif + + -------------------------------------------------------------------------------- import Hakyll.Core.Identifier -import Hakyll.Core.Store +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File +-------------------------------------------------------------------------------- +-- | Because UTCTime doesn't have a Binary instance... +newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime} + deriving (Eq, NFData, Ord, Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary BinaryTime where + put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) = + put d >> put (floor dt :: Integer) + + get = fmap BinaryTime $ UTCTime + <$> (ModifiedJulianDay <$> get) + <*> (secondsToDiffTime <$> get) + + +-------------------------------------------------------------------------------- +data ResourceInfo = ResourceInfo + { resourceInfoModified :: BinaryTime + , resourceInfoMetadata :: Maybe Identifier + } deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary ResourceInfo where + put (ResourceInfo mtime meta) = put mtime >> put meta + get = ResourceInfo <$> get <*> get + + +-------------------------------------------------------------------------------- +instance NFData ResourceInfo where + rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` () + + -------------------------------------------------------------------------------- -- | Responsible for retrieving and listing resources data Provider = Provider { -- Top of the provided directory - providerDirectory :: FilePath + providerDirectory :: FilePath , -- | A list of all files found - providerSet :: Set Identifier - , -- | Cache keeping track of modified files - providerModifiedCache :: IORef (Map Identifier Bool) + providerFiles :: Map Identifier ResourceInfo + , -- | A list of the files from the previous run + providerOldFiles :: Map Identifier ResourceInfo , -- | Underlying persistent store for caching - providerStore :: Store + providerStore :: Store } @@ -51,29 +108,47 @@ newProvider :: Store -- ^ Store to use -> FilePath -- ^ Search directory -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do - list <- map fromFilePath <$> getRecursiveContents ignore directory - cache <- newIORef M.empty - return $ Provider directory (S.fromList list) cache store + list <- map fromFilePath <$> getRecursiveContents ignore directory + let universe = S.fromList list + files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do + rInfo <- getResourceInfo directory universe identifier + return (identifier, rInfo) + + -- Get the old files from the store, and then immediately replace them by + -- the new files. + oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey + oldFiles `deepseq` Store.set store oldKey files + + return $ Provider directory files oldFiles store + where + oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"] + + -- Update modified if metadata is modified + maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) -> + let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files + in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod} + + +-------------------------------------------------------------------------------- +getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo +getResourceInfo directory universe identifier = do + mtime <- fileModificationTime $ directory toFilePath identifier + return $ ResourceInfo (BinaryTime mtime) $ + if mdRsc `S.member` universe then Just mdRsc else Nothing + where + mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier -------------------------------------------------------------------------------- resourceList :: Provider -> [Identifier] -resourceList = S.toList . providerSet +resourceList = M.keys . providerFiles -------------------------------------------------------------------------------- -- | Check if a given resource exists resourceExists :: Provider -> Identifier -> Bool resourceExists provider = - (`S.member` providerSet provider) . setVersion Nothing - - --------------------------------------------------------------------------------- --- | Each resource may have an associated metadata resource (with a @.metadata@ --- filename) -resourceMetadataResource :: Identifier -> Identifier -resourceMetadataResource = - fromFilePath . flip addExtension "metadata" . toFilePath + (`M.member` providerFiles provider) . setVersion Nothing -------------------------------------------------------------------------------- @@ -91,3 +166,37 @@ resourceString p i = readFile $ resourceFilePath p i -- | Get the raw body of a resource of a lazy bytestring resourceLBS :: Provider -> Identifier -> IO BL.ByteString resourceLBS p i = BL.readFile $ resourceFilePath p i + + +-------------------------------------------------------------------------------- +-- | A resource is modified if it or its metadata has changed +resourceModified :: Provider -> Identifier -> Bool +resourceModified p r = case (ri, oldRi) of + (Nothing, _) -> True + (Just _, Nothing) -> True + (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o + where + ri = M.lookup (setVersion Nothing r) (providerFiles p) + oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles p) + + +-------------------------------------------------------------------------------- +resourceModificationTime :: Provider -> Identifier -> UTCTime +resourceModificationTime p i = + case M.lookup (setVersion Nothing i) (providerFiles p) of + Just ri -> unBinaryTime $ resourceInfoModified ri + Nothing -> error $ + "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++ + "resource " ++ show i ++ " does not exist" + + +-------------------------------------------------------------------------------- +fileModificationTime :: FilePath -> IO UTCTime +fileModificationTime fp = do +#if MIN_VERSION_directory(1,2,0) + getModificationTime fp +#else + ct <- toCalendarTime =<< getModificationTime fp + let str = formatCalendarTime defaultTimeLocale "%s" ct + return $ readTime defaultTimeLocale "%s" str +#endif diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs index 52c07cb..276483b 100644 --- a/src/Hakyll/Core/Provider/Metadata.hs +++ b/src/Hakyll/Core/Provider/Metadata.hs @@ -31,13 +31,14 @@ loadMetadata p identifier = do then second Just <$> loadMetadataHeader fp else return (M.empty, Nothing) - emd <- if resourceExists p mi then loadMetadataFile mfp else return M.empty + emd <- case mi of + Nothing -> return M.empty + Just mi' -> loadMetadataFile $ resourceFilePath p mi' return (M.union md emd, body) where fp = resourceFilePath p identifier - mi = resourceMetadataResource identifier - mfp = resourceFilePath p mi + mi = M.lookup identifier (providerFiles p) >>= resourceInfoMetadata -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Core/Provider/MetadataCache.hs b/src/Hakyll/Core/Provider/MetadataCache.hs index b813303..2c97baa 100644 --- a/src/Hakyll/Core/Provider/MetadataCache.hs +++ b/src/Hakyll/Core/Provider/MetadataCache.hs @@ -23,6 +23,7 @@ resourceMetadata :: Provider -> Identifier -> IO Metadata resourceMetadata p r | not (resourceExists p r) = return M.empty | otherwise = do + -- TODO keep time in md cache load p r Store.Found md <- Store.get (providerStore p) [name, toFilePath r, "metadata"] diff --git a/src/Hakyll/Core/Provider/Modified.hs b/src/Hakyll/Core/Provider/Modified.hs deleted file mode 100644 index 4c3bdc5..0000000 --- a/src/Hakyll/Core/Provider/Modified.hs +++ /dev/null @@ -1,115 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Hakyll.Core.Provider.Modified - ( resourceModified - , resourceModificationTime - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (when) -import Data.Binary (Binary (..)) -import Data.IORef -import qualified Data.Map as M -import Data.Time (Day (..), UTCTime (..), - secondsToDiffTime) -import Data.Typeable (Typeable) -import System.Directory (getModificationTime) - - --------------------------------------------------------------------------------- -#if !MIN_VERSION_directory(1,2,0) -import Data.Time (readTime) -import System.Locale (defaultTimeLocale) -import System.Time (formatCalendarTime, - toCalendarTime) -#endif - - --------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Provider.Internal -import Hakyll.Core.Provider.MetadataCache -import Hakyll.Core.Store (Store) -import qualified Hakyll.Core.Store as Store - - --------------------------------------------------------------------------------- --- | A resource is modified if it or its metadata has changed -resourceModified :: Provider -> Identifier -> IO Bool -resourceModified p r - | not exists = return False - | otherwise = do - cache <- readIORef cacheRef - case M.lookup normalized cache of - Just m -> return m - Nothing -> do - -- Check if the actual file was modified, and do a recursive - -- call to check if the metadata file was modified - m <- (||) - <$> fileModified store filePath - <*> resourceModified p (resourceMetadataResource r) - modifyIORef cacheRef (M.insert normalized m) - - -- Important! (But ugly) - when m $ resourceInvalidateMetadataCache p r - - return m - where - normalized = setVersion Nothing r - exists = resourceExists p r - store = providerStore p - cacheRef = providerModifiedCache p - filePath = resourceFilePath p r - - --------------------------------------------------------------------------------- --- | Utility: Check if a file was modified recently -fileModified :: Store -> FilePath -> IO Bool -fileModified store fp = do - lastModified <- Store.get store key - newModified <- BinaryTime <$> fileModificationTime fp - if maybe False (>= newModified) (Store.toMaybe lastModified) - -- All is fine, not modified - then return False - -- Resource modified; store new digest - else do - Store.set store key newModified - return True - where - key = ["Hakyll.Core.Resource.Provider.fileModified", fp] - - --------------------------------------------------------------------------------- -resourceModificationTime :: Provider -> Identifier -> IO UTCTime -resourceModificationTime p i = fileModificationTime $ resourceFilePath p i - - --------------------------------------------------------------------------------- -fileModificationTime :: FilePath -> IO UTCTime -fileModificationTime fp = do -#if MIN_VERSION_directory(1,2,0) - getModificationTime fp -#else - ct <- toCalendarTime =<< getModificationTime fp - let str = formatCalendarTime defaultTimeLocale "%s" ct - return $ readTime defaultTimeLocale "%s" str -#endif - - --------------------------------------------------------------------------------- --- | Because UTCTime doesn't have a Binary instance... -newtype BinaryTime = BinaryTime UTCTime - deriving (Eq, Ord, Typeable) - - --------------------------------------------------------------------------------- -instance Binary BinaryTime where - put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) = - put d >> put (floor dt :: Integer) - - get = fmap BinaryTime $ UTCTime - <$> (ModifiedJulianDay <$> get) - <*> (secondsToDiffTime <$> get) diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs index b7dc4e8..150cc60 100644 --- a/src/Hakyll/Core/Runtime.hs +++ b/src/Hakyll/Core/Runtime.hs @@ -6,7 +6,7 @@ module Hakyll.Core.Runtime -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) -import Control.Monad (filterM, unless) +import Control.Monad (unless) import Control.Monad.Error (ErrorT, runErrorT, throwError) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) @@ -140,8 +140,9 @@ scheduleOutOfDate = do todo <- runtimeTodo <$> get let identifiers = M.keys universe - modified <- fmap S.fromList $ flip filterM identifiers $ - liftIO . resourceModified provider + modified = S.fromList $ flip filter identifiers $ + resourceModified provider + let (ood, facts', msgs) = outOfDate identifiers modified facts todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index fcb527a..8aab989 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -207,8 +207,7 @@ modificationTimeFieldWith :: TimeLocale -- ^ Time output locale -> Context a -- ^ Resulting context modificationTimeFieldWith locale key fmt = field key $ \i -> do provider <- compilerProvider <$> compilerAsk - mtime <- compilerUnsafeIO $ - resourceModificationTime provider $ itemIdentifier i + let mtime = resourceModificationTime provider $ itemIdentifier i return $ formatTime locale fmt mtime diff --git a/tests/Hakyll/Core/Provider/Tests.hs b/tests/Hakyll/Core/Provider/Tests.hs index 5fd9c0d..abe5c1d 100644 --- a/tests/Hakyll/Core/Provider/Tests.hs +++ b/tests/Hakyll/Core/Provider/Tests.hs @@ -37,3 +37,4 @@ case01 = do doesntExist <- resourceMetadata provider "doesntexist.md" M.empty @=? doesntExist + cleanTestEnv diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs index d43772d..ee12010 100644 --- a/tests/Hakyll/Core/Rules/Tests.hs +++ b/tests/Hakyll/Core/Rules/Tests.hs @@ -51,6 +51,7 @@ rulesTest = do Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md") Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md") readIORef ioref >>= assert + cleanTestEnv where sv g = setVersion (Just g) expected = diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs index 19b268b..95140e3 100644 --- a/tests/Hakyll/Core/Store/Tests.hs +++ b/tests/Hakyll/Core/Store/Tests.hs @@ -67,3 +67,4 @@ wrongType = do e == typeOf (undefined :: Int) && t == typeOf (undefined :: String) _ -> False + cleanTestEnv diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs index 6fb5233..b96cfa5 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -44,6 +44,7 @@ case01 = do pandocCompiler >>= applyTemplate (itemBody tpl) testContext out @=? itemBody item + cleanTestEnv -------------------------------------------------------------------------------- @@ -63,6 +64,7 @@ testApplyJoinTemplateList = do applyJoinTemplateList ", " tpl defaultContext [i1, i2] str @?= "Hello, World" + cleanTestEnv where i1 = Item "item1" "Hello" i2 = Item "item2" "World" -- cgit v1.2.3 From 8c575ae52115f09d5b6e53ed409d934f5168de59 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 10 Feb 2013 22:15:34 +0100 Subject: Fix apparent remaining provider rewrite issues --- src/Hakyll/Core/Provider.hs | 11 ++++------- src/Hakyll/Core/Provider/Internal.hs | 7 ++++--- 2 files changed, 8 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Provider.hs b/src/Hakyll/Core/Provider.hs index 4dd8288..00b694d 100644 --- a/src/Hakyll/Core/Provider.hs +++ b/src/Hakyll/Core/Provider.hs @@ -23,7 +23,6 @@ module Hakyll.Core.Provider -------------------------------------------------------------------------------- -import Control.Monad (forM_) import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal import Hakyll.Core.Store (Store) @@ -37,9 +36,7 @@ newProvider :: Store -- ^ Store to use -> IO Internal.Provider -- ^ Resulting provider newProvider store ignore directory = do -- Delete metadata cache where necessary - provider <- Internal.newProvider store ignore directory - forM_ (Internal.resourceList provider) $ \identifier -> - if Internal.resourceModified provider identifier - then Internal.resourceInvalidateMetadataCache provider identifier - else return () - return provider + p <- Internal.newProvider store ignore directory + mapM_ (Internal.resourceInvalidateMetadataCache p) $ + filter (Internal.resourceModified p) $ Internal.resourceList p + return p diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs index 64b19c8..5c3d07e 100644 --- a/src/Hakyll/Core/Provider/Internal.hs +++ b/src/Hakyll/Core/Provider/Internal.hs @@ -172,12 +172,13 @@ resourceLBS p i = BL.readFile $ resourceFilePath p i -- | A resource is modified if it or its metadata has changed resourceModified :: Provider -> Identifier -> Bool resourceModified p r = case (ri, oldRi) of - (Nothing, _) -> True + (Nothing, _) -> False (Just _, Nothing) -> True (Just n, Just o) -> resourceInfoModified n > resourceInfoModified o where - ri = M.lookup (setVersion Nothing r) (providerFiles p) - oldRi = ri >>= resourceInfoMetadata >>= flip M.lookup (providerFiles p) + normal = setVersion Nothing r + ri = M.lookup normal (providerFiles p) + oldRi = M.lookup normal (providerOldFiles p) -------------------------------------------------------------------------------- -- cgit v1.2.3