From 877cb21d1630d32c6e40eb7c6f0ecc7e1da2bd52 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 18 Nov 2012 21:56:52 +0100 Subject: Add Item abstraction --- src/Hakyll.hs | 4 +- src/Hakyll/Core/CompiledItem.hs | 55 ---------- src/Hakyll/Core/Compiler.hs | 51 ++++----- src/Hakyll/Core/Compiler/Internal.hs | 8 +- src/Hakyll/Core/Item.hs | 41 +++++++ src/Hakyll/Core/Item/SomeItem.hs | 23 ++++ src/Hakyll/Core/Provider.hs | 46 ++++++++ src/Hakyll/Core/Provider/Internal.hs | 86 +++++++++++++++ src/Hakyll/Core/Provider/Metadata.hs | 125 ++++++++++++++++++++++ src/Hakyll/Core/Provider/MetadataCache.hs | 62 +++++++++++ src/Hakyll/Core/Provider/Modified.hs | 83 ++++++++++++++ src/Hakyll/Core/ResourceProvider.hs | 46 -------- src/Hakyll/Core/ResourceProvider/Internal.hs | 86 --------------- src/Hakyll/Core/ResourceProvider/Metadata.hs | 125 ---------------------- src/Hakyll/Core/ResourceProvider/MetadataCache.hs | 62 ----------- src/Hakyll/Core/ResourceProvider/Modified.hs | 83 -------------- src/Hakyll/Core/Rules.hs | 19 ++-- src/Hakyll/Core/Rules/Internal.hs | 20 ++-- src/Hakyll/Core/Runtime.hs | 25 +++-- src/Hakyll/Core/Writable.hs | 50 +++++---- src/Hakyll/Core/Writable/CopyFile.hs | 22 ++-- src/Hakyll/Web/CompressCss.hs | 5 +- src/Hakyll/Web/Page.hs | 25 ++--- src/Hakyll/Web/Page/Internal.hs | 8 -- src/Hakyll/Web/Pandoc.hs | 87 ++++++--------- src/Hakyll/Web/Pandoc/Biblio.hs | 57 ++++++---- src/Hakyll/Web/Pandoc/FileType.hs | 9 +- src/Hakyll/Web/Template.hs | 56 +++++----- src/Hakyll/Web/Template/Context.hs | 39 +++---- src/Hakyll/Web/Urls/Relativize.hs | 24 ++--- 30 files changed, 717 insertions(+), 715 deletions(-) delete mode 100644 src/Hakyll/Core/CompiledItem.hs create mode 100644 src/Hakyll/Core/Item.hs create mode 100644 src/Hakyll/Core/Item/SomeItem.hs create mode 100644 src/Hakyll/Core/Provider.hs create mode 100644 src/Hakyll/Core/Provider/Internal.hs create mode 100644 src/Hakyll/Core/Provider/Metadata.hs create mode 100644 src/Hakyll/Core/Provider/MetadataCache.hs create mode 100644 src/Hakyll/Core/Provider/Modified.hs delete mode 100644 src/Hakyll/Core/ResourceProvider.hs delete mode 100644 src/Hakyll/Core/ResourceProvider/Internal.hs delete mode 100644 src/Hakyll/Core/ResourceProvider/Metadata.hs delete mode 100644 src/Hakyll/Core/ResourceProvider/MetadataCache.hs delete mode 100644 src/Hakyll/Core/ResourceProvider/Modified.hs delete mode 100644 src/Hakyll/Web/Page/Internal.hs (limited to 'src') diff --git a/src/Hakyll.hs b/src/Hakyll.hs index d7ad536..a956ecd 100644 --- a/src/Hakyll.hs +++ b/src/Hakyll.hs @@ -6,8 +6,8 @@ module Hakyll , module Hakyll.Core.Configuration , module Hakyll.Core.Identifier , module Hakyll.Core.Identifier.Pattern + , module Hakyll.Core.Item , module Hakyll.Core.Metadata - , module Hakyll.Core.ResourceProvider , module Hakyll.Core.Routes , module Hakyll.Core.Rules #ifdef UNIX_FILTER @@ -39,8 +39,8 @@ import Hakyll.Core.Compiler import Hakyll.Core.Configuration import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Item import Hakyll.Core.Metadata -import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Rules #ifdef UNIX_FILTER diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs deleted file mode 100644 index 85e85b3..0000000 --- a/src/Hakyll/Core/CompiledItem.hs +++ /dev/null @@ -1,55 +0,0 @@ --------------------------------------------------------------------------------- --- | A module containing a box datatype representing a compiled item. This --- item can be of any type, given that a few restrictions hold: --- --- * we need a 'Typeable' instance to perform type-safe casts; --- --- * we need a 'Binary' instance so we can serialize these items to the cache; --- --- * we need a 'Writable' instance so the results can be saved. -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -module Hakyll.Core.CompiledItem - ( CompiledItem (..) - , compiledItem - , unCompiledItem - ) where - - --------------------------------------------------------------------------------- -import Data.Binary (Binary) -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable, cast, typeOf) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Writable - - --------------------------------------------------------------------------------- --- | Box type for a compiled item --- -data CompiledItem = forall a. (Binary a, Typeable a, Writable a) - => CompiledItem a - deriving (Typeable) - - --------------------------------------------------------------------------------- -instance Writable CompiledItem where - write p (CompiledItem x) = write p x - - --------------------------------------------------------------------------------- --- | Box a value into a 'CompiledItem' -compiledItem :: (Binary a, Typeable a, Writable a) => a -> CompiledItem -compiledItem = CompiledItem - - --------------------------------------------------------------------------------- --- | Unbox a value from a 'CompiledItem' -unCompiledItem :: (Binary a, Typeable a, Writable a) => CompiledItem -> a -unCompiledItem (CompiledItem x) = fromMaybe error' $ cast x - where - error' = error $ - "Hakyll.Core.CompiledItem.unCompiledItem: " ++ - "unsupported type (got " ++ show (typeOf x) ++ ")" diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index e1b33d2..a5c7a41 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -3,11 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Core.Compiler ( Compiler - , getIdentifier + , getUnderlying + , makeItem , getRoute - , getRouteFor , getMetadata - , getMetadataFor , getResourceBody , getResourceString , getResourceLBS @@ -34,42 +33,39 @@ import Hakyll.Core.Compiler.Internal import Hakyll.Core.Compiler.Require import Hakyll.Core.Dependencies import Hakyll.Core.Identifier +import Hakyll.Core.Item import Hakyll.Core.Logger as Logger import Hakyll.Core.Metadata -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Provider import Hakyll.Core.Routes import qualified Hakyll.Core.Store as Store -import Hakyll.Core.Writable -------------------------------------------------------------------------------- --- | Get the identifier of the item that is currently being compiled -getIdentifier :: Compiler Identifier -getIdentifier = compilerIdentifier <$> compilerAsk +-- | Get the underlying identifier. Only use this if you know what you're doing. +getUnderlying :: Compiler Identifier +getUnderlying = compilerUnderlying <$> compilerAsk -------------------------------------------------------------------------------- --- | Get the route we are using for this item -getRoute :: Compiler (Maybe FilePath) -getRoute = getIdentifier >>= getRouteFor +makeItem :: a -> Compiler (Item a) +makeItem x = do + identifier <- getUnderlying + return $ Item identifier x -------------------------------------------------------------------------------- -- | Get the route for a specified item -getRouteFor :: Identifier -> Compiler (Maybe FilePath) -getRouteFor identifier = do +getRoute :: Identifier -> Compiler (Maybe FilePath) +getRoute identifier = do routes <- compilerRoutes <$> compilerAsk return $ runRoutes routes identifier --------------------------------------------------------------------------------- -getMetadata :: Compiler Metadata -getMetadata = getIdentifier >>= getMetadataFor - -------------------------------------------------------------------------------- -getMetadataFor :: Identifier -> Compiler Metadata -getMetadataFor identifier = do +getMetadata :: Identifier -> Compiler Metadata +getMetadata identifier = do provider <- compilerProvider <$> compilerAsk compilerTellDependencies [IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier @@ -77,32 +73,31 @@ getMetadataFor identifier = do -------------------------------------------------------------------------------- -- | Get the body of the underlying resource -getResourceBody :: Compiler String +getResourceBody :: Compiler (Item String) getResourceBody = getResourceWith resourceBody -------------------------------------------------------------------------------- -- | Get the resource we are compiling as a string -getResourceString :: Compiler String +getResourceString :: Compiler (Item String) getResourceString = getResourceWith $ const resourceString -------------------------------------------------------------------------------- -- | Get the resource we are compiling as a lazy bytestring --- -getResourceLBS :: Compiler ByteString +getResourceLBS :: Compiler (Item ByteString) getResourceLBS = getResourceWith $ const resourceLBS -------------------------------------------------------------------------------- -- | Overloadable function for 'getResourceString' and 'getResourceLBS' -getResourceWith :: (ResourceProvider -> Identifier -> IO a) -> Compiler a +getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a) getResourceWith reader = do provider <- compilerProvider <$> compilerAsk - id' <- compilerIdentifier <$> compilerAsk + id' <- compilerUnderlying <$> compilerAsk let filePath = toFilePath id' if resourceExists provider id' - then compilerUnsafeIO $ reader provider id' + then compilerUnsafeIO $ Item id' <$> reader provider id' else compilerThrow $ error' filePath where error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++ @@ -110,12 +105,12 @@ getResourceWith reader = do -------------------------------------------------------------------------------- -cached :: (Binary a, Typeable a, Writable a) +cached :: (Binary a, Typeable a) => String -> Compiler a -> Compiler a cached name compiler = do - id' <- compilerIdentifier <$> compilerAsk + id' <- compilerUnderlying <$> compilerAsk store <- compilerStore <$> compilerAsk provider <- compilerProvider <$> compilerAsk modified <- compilerUnsafeIO $ resourceModified provider id' diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 5987eb8..89227ef 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -35,7 +35,7 @@ import Data.Monoid (Monoid (..)) import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Logger -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Provider import Hakyll.Core.Routes import Hakyll.Core.Store @@ -43,10 +43,10 @@ import Hakyll.Core.Store -------------------------------------------------------------------------------- -- | Environment in which a compiler runs data CompilerRead = CompilerRead - { -- | Target identifier - compilerIdentifier :: Identifier + { -- | Underlying identifier + compilerUnderlying :: Identifier , -- | Resource provider - compilerProvider :: ResourceProvider + compilerProvider :: Provider , -- | List of all known identifiers compilerUniverse :: [Identifier] , -- | Site routes diff --git a/src/Hakyll/Core/Item.hs b/src/Hakyll/Core/Item.hs new file mode 100644 index 0000000..1f9af8e --- /dev/null +++ b/src/Hakyll/Core/Item.hs @@ -0,0 +1,41 @@ +-------------------------------------------------------------------------------- +-- | An item is a combination of some content and its 'Identifier'. This way, we +-- can still use the 'Identifier' to access metadata. +{-# LANGUAGE DeriveDataTypeable #-} +module Hakyll.Core.Item + ( Item (..) + , itemSetBody + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Data.Binary (Binary (..)) +import Data.Typeable (Typeable) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +data Item a = Item + { itemIdentifier :: Identifier + , itemBody :: a + } deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Functor Item where + fmap f (Item i x) = Item i (f x) + + +-------------------------------------------------------------------------------- +instance Binary a => Binary (Item a) where + put (Item i x) = put i >> put x + get = Item <$> get <*> get + + +-------------------------------------------------------------------------------- +itemSetBody :: a -> Item b -> Item a +itemSetBody x (Item i _) = Item i x diff --git a/src/Hakyll/Core/Item/SomeItem.hs b/src/Hakyll/Core/Item/SomeItem.hs new file mode 100644 index 0000000..c5ba0df --- /dev/null +++ b/src/Hakyll/Core/Item/SomeItem.hs @@ -0,0 +1,23 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +module Hakyll.Core.Item.SomeItem + ( SomeItem (..) + ) where + + +-------------------------------------------------------------------------------- +import Data.Binary (Binary) +import Data.Typeable (Typeable) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Item +import Hakyll.Core.Writable + + +-------------------------------------------------------------------------------- +-- | An existential type, mostly for internal usage. +data SomeItem = forall a. + (Binary a, Typeable a, Writable a) => SomeItem (Item a) + deriving (Typeable) diff --git a/src/Hakyll/Core/Provider.hs b/src/Hakyll/Core/Provider.hs new file mode 100644 index 0000000..64b3786 --- /dev/null +++ b/src/Hakyll/Core/Provider.hs @@ -0,0 +1,46 @@ +-------------------------------------------------------------------------------- +-- | This module provides an wrapper API around the file system which does some +-- caching. +module Hakyll.Core.Provider + ( -- * Constructing resource providers + Provider + , newProvider + + -- * Querying resource properties + , resourceList + , resourceExists + , resourceModified + , resourceModificationTime + + -- * Access to raw resource content + , resourceString + , resourceLBS + + -- * Access to metadata and body content + , resourceMetadata + , resourceBody + ) where + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.Provider.Internal +import qualified Hakyll.Core.Provider.MetadataCache as Internal +import Hakyll.Core.Provider.Modified + + +-------------------------------------------------------------------------------- +-- | 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 diff --git a/src/Hakyll/Core/Provider/Internal.hs b/src/Hakyll/Core/Provider/Internal.hs new file mode 100644 index 0000000..54332a9 --- /dev/null +++ b/src/Hakyll/Core/Provider/Internal.hs @@ -0,0 +1,86 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Provider.Internal + ( Provider (..) + , newProvider + + , resourceList + , resourceExists + , resourceMetadataResource + + , resourceString + , resourceLBS + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import System.FilePath (addExtension) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Store +import Hakyll.Core.Util.File +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +-- | Responsible for retrieving and listing resources +data Provider = Provider + { -- | A list of all files found + providerSet :: Set Identifier + , -- | Cache keeping track of modified files + providerModifiedCache :: IORef (Map Identifier Bool) + , -- | Underlying persistent store for caching + providerStore :: Store + } + + +-------------------------------------------------------------------------------- +-- | Create a resource provider +newProvider :: Store -- ^ Store to use + -> (FilePath -> Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO Provider -- ^ Resulting provider +newProvider store ignore directory = do + list <- map fromFilePath . filter (not . ignore) <$> + getRecursiveContents False directory + cache <- newIORef M.empty + return $ Provider (S.fromList list) cache store + + +-------------------------------------------------------------------------------- +resourceList :: Provider -> [Identifier] +resourceList = S.toList . providerSet + + +-------------------------------------------------------------------------------- +-- | 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 + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource as string +resourceString :: Identifier -> IO String +resourceString = readFile . toFilePath + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource of a lazy bytestring +resourceLBS :: Identifier -> IO BL.ByteString +resourceLBS = BL.readFile . toFilePath diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs new file mode 100644 index 0000000..18536f4 --- /dev/null +++ b/src/Hakyll/Core/Provider/Metadata.hs @@ -0,0 +1,125 @@ +-------------------------------------------------------------------------------- +-- | Internal module to parse metadata +module Hakyll.Core.Provider.Metadata + ( loadMetadata + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative +import Control.Arrow (second) +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map as M +import System.IO as IO +import Text.Parsec (()) +import qualified Text.Parsec as P +import Text.Parsec.String (Parser) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.Provider.Internal +import Hakyll.Core.Util.String + + +-------------------------------------------------------------------------------- +loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String) +loadMetadata rp identifier = do + hasHeader <- probablyHasMetadataHeader fp + (md, body) <- if hasHeader + then second Just <$> loadMetadataHeader fp + else return (M.empty, Nothing) + + emd <- if resourceExists rp mi then loadMetadataFile mfp else return M.empty + + return (M.union md emd, body) + where + fp = toFilePath identifier + mi = resourceMetadataResource identifier + mfp = toFilePath mi + + +-------------------------------------------------------------------------------- +loadMetadataHeader :: FilePath -> IO (Metadata, String) +loadMetadataHeader fp = do + contents <- readFile fp + case P.parse page fp contents of + Left err -> error (show err) + Right (md, b) -> return (M.fromList md, b) + + +-------------------------------------------------------------------------------- +loadMetadataFile :: FilePath -> IO Metadata +loadMetadataFile fp = do + contents <- readFile fp + case P.parse metadata fp contents of + Left err -> error (show err) + Right md -> return $ M.fromList md + + +-------------------------------------------------------------------------------- +-- | Check if a file "probably" has a metadata header. The main goal of this is +-- to exclude binary files (which are unlikely to start with "---"). +probablyHasMetadataHeader :: FilePath -> IO Bool +probablyHasMetadataHeader fp = do + handle <- IO.openFile fp IO.ReadMode + bs <- BC.hGet handle 1024 + IO.hClose handle + return $ isMetadataHeader bs + where + isMetadataHeader bs = + let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs + in BC.length pre >= 3 && BC.all (== '-') pre + + +-------------------------------------------------------------------------------- +-- | Space or tab, no newline +inlineSpace :: Parser Char +inlineSpace = P.oneOf ['\t', ' '] "space" + + +-------------------------------------------------------------------------------- +-- | Parse Windows newlines as well (i.e. "\n" or "\r\n") +newline :: Parser String +newline = P.string "\n" <|> P.string "\r\n" + + +-------------------------------------------------------------------------------- +-- | Parse a single metadata field +metadataField :: Parser (String, String) +metadataField = do + key <- P.manyTill P.alphaNum $ P.char ':' + P.skipMany1 inlineSpace "space followed by metadata for: " ++ key + value <- P.manyTill P.anyChar newline + trailing' <- P.many trailing + return (key, trim $ value ++ concat trailing') + where + trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar newline + + +-------------------------------------------------------------------------------- +-- | Parse a metadata block +metadata :: Parser [(String, String)] +metadata = P.many metadataField + + +-------------------------------------------------------------------------------- +-- | Parse a metadata block, including delimiters and trailing newlines +metadataBlock :: Parser [(String, String)] +metadataBlock = do + open <- P.many1 (P.char '-') <* P.many inlineSpace <* newline + metadata' <- metadata + _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.'] + P.skipMany inlineSpace + P.skipMany1 newline + return metadata' + + +-------------------------------------------------------------------------------- +-- | Parse a page consisting of a metadata header and a body +page :: Parser ([(String, String)], String) +page = do + metadata' <- P.option [] metadataBlock + body <- P.many P.anyChar + return (metadata', body) diff --git a/src/Hakyll/Core/Provider/MetadataCache.hs b/src/Hakyll/Core/Provider/MetadataCache.hs new file mode 100644 index 0000000..cd67370 --- /dev/null +++ b/src/Hakyll/Core/Provider/MetadataCache.hs @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Provider.MetadataCache + ( resourceMetadata + , resourceBody + , resourceInvalidateMetadataCache + ) where + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.Provider.Internal +import Hakyll.Core.Provider.Metadata +import qualified Hakyll.Core.Store as Store + + +-------------------------------------------------------------------------------- +resourceMetadata :: Provider -> Identifier -> IO Metadata +resourceMetadata p r = do + load p r + Store.Found md <- Store.get (providerStore p) + [name, toFilePath r, "metadata"] + return md + + +-------------------------------------------------------------------------------- +resourceBody :: Provider -> Identifier -> IO String +resourceBody p r = do + load p r + Store.Found bd <- Store.get (providerStore p) + [name, toFilePath r, "body"] + maybe (resourceString r) return bd + + +-------------------------------------------------------------------------------- +resourceInvalidateMetadataCache :: Provider -> Identifier -> IO () +resourceInvalidateMetadataCache p r = do + Store.delete (providerStore p) [name, toFilePath r, "metadata"] + Store.delete (providerStore p) [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +load :: Provider -> Identifier -> IO () +load p r = do + mmd <- Store.get store mdk :: IO (Store.Result Metadata) + case mmd of + -- Already loaded + Store.Found _ -> return () + -- Not yet loaded + _ -> do + (metadata, body) <- loadMetadata p r + Store.set store mdk metadata + Store.set store bk body + where + store = providerStore p + mdk = [name, toFilePath r, "metadata"] + bk = [name, toFilePath r, "body"] + + +-------------------------------------------------------------------------------- +name :: String +name = "Hakyll.Core.Resource.Provider.MetadataCache" diff --git a/src/Hakyll/Core/Provider/Modified.hs b/src/Hakyll/Core/Provider/Modified.hs new file mode 100644 index 0000000..166019d --- /dev/null +++ b/src/Hakyll/Core/Provider/Modified.hs @@ -0,0 +1,83 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Provider.Modified + ( resourceModified + , resourceModificationTime + ) where + + +-------------------------------------------------------------------------------- +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.IORef +import qualified Data.Map as M +import Data.Time (UTCTime) +import System.Directory (getModificationTime) + + +-------------------------------------------------------------------------------- +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 rp 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 <- (||) + <$> fileDigestModified store (toFilePath r) + <*> resourceModified rp (resourceMetadataResource r) + modifyIORef cacheRef (M.insert normalized m) + + -- Important! (But ugly) + when m $ resourceInvalidateMetadataCache rp r + + return m + where + normalized = setVersion Nothing r + exists = resourceExists rp r + store = providerStore rp + cacheRef = providerModifiedCache rp + + +-------------------------------------------------------------------------------- +-- | 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 + -- All is fine, not modified + then return False + -- Resource modified; store new digest + else do + Store.set store key newDigest + 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 :: Identifier -> IO UTCTime +resourceModificationTime = getModificationTime . toFilePath diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs deleted file mode 100644 index 04b5625..0000000 --- a/src/Hakyll/Core/ResourceProvider.hs +++ /dev/null @@ -1,46 +0,0 @@ --------------------------------------------------------------------------------- --- | This module provides an wrapper API around the file system which does some --- caching. -module Hakyll.Core.ResourceProvider - ( -- * Constructing resource providers - ResourceProvider - , newResourceProvider - - -- * Querying resource properties - , resourceList - , resourceExists - , resourceModified - , resourceModificationTime - - -- * Access to raw resource content - , resourceString - , resourceLBS - - -- * Access to metadata and body content - , resourceMetadata - , resourceBody - ) where - - --------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Metadata -import Hakyll.Core.ResourceProvider.Internal -import qualified Hakyll.Core.ResourceProvider.MetadataCache as Internal -import Hakyll.Core.ResourceProvider.Modified - - --------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceMetadata :: ResourceProvider -> Identifier -> IO Metadata -resourceMetadata rp r = do - _ <- resourceModified rp r - Internal.resourceMetadata rp r - - --------------------------------------------------------------------------------- --- | Wrapper to ensure metadata cache is invalidated if necessary -resourceBody :: ResourceProvider -> Identifier -> IO String -resourceBody rp r = do - _ <- resourceModified rp r - Internal.resourceBody rp r diff --git a/src/Hakyll/Core/ResourceProvider/Internal.hs b/src/Hakyll/Core/ResourceProvider/Internal.hs deleted file mode 100644 index 628d1b5..0000000 --- a/src/Hakyll/Core/ResourceProvider/Internal.hs +++ /dev/null @@ -1,86 +0,0 @@ --------------------------------------------------------------------------------- -module Hakyll.Core.ResourceProvider.Internal - ( ResourceProvider (..) - , newResourceProvider - - , resourceList - , resourceExists - , resourceMetadataResource - - , resourceString - , resourceLBS - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import qualified Data.ByteString.Lazy as BL -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import System.FilePath (addExtension) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Store -import Hakyll.Core.Util.File -import Hakyll.Core.Identifier - - --------------------------------------------------------------------------------- --- | Responsible for retrieving and listing resources -data ResourceProvider = ResourceProvider - { -- | A list of all files found - resourceSet :: Set Identifier - , -- | Cache keeping track of modified files - resourceModifiedCache :: IORef (Map Identifier Bool) - , -- | Underlying persistent store for caching - resourceStore :: Store - } - - --------------------------------------------------------------------------------- --- | Create a resource provider -newResourceProvider :: Store -- ^ Store to use - -> (FilePath -> Bool) -- ^ Should we ignore this file? - -> FilePath -- ^ Search directory - -> IO ResourceProvider -- ^ Resulting provider -newResourceProvider store ignore directory = do - list <- map fromFilePath . filter (not . ignore) <$> - getRecursiveContents False directory - cache <- newIORef M.empty - return $ ResourceProvider (S.fromList list) cache store - - --------------------------------------------------------------------------------- -resourceList :: ResourceProvider -> [Identifier] -resourceList = S.toList . resourceSet - - --------------------------------------------------------------------------------- --- | Check if a given resource exists -resourceExists :: ResourceProvider -> Identifier -> Bool -resourceExists provider = - (`S.member` resourceSet provider) . setVersion Nothing - - --------------------------------------------------------------------------------- --- | Each resource may have an associated metadata resource (with a @.metadata@ --- filename) -resourceMetadataResource :: Identifier -> Identifier -resourceMetadataResource = - fromFilePath . flip addExtension "metadata" . toFilePath - - --------------------------------------------------------------------------------- --- | Get the raw body of a resource as string -resourceString :: Identifier -> IO String -resourceString = readFile . toFilePath - - --------------------------------------------------------------------------------- --- | Get the raw body of a resource of a lazy bytestring -resourceLBS :: Identifier -> IO BL.ByteString -resourceLBS = BL.readFile . toFilePath diff --git a/src/Hakyll/Core/ResourceProvider/Metadata.hs b/src/Hakyll/Core/ResourceProvider/Metadata.hs deleted file mode 100644 index 50af0c9..0000000 --- a/src/Hakyll/Core/ResourceProvider/Metadata.hs +++ /dev/null @@ -1,125 +0,0 @@ --------------------------------------------------------------------------------- --- | Internal module to parse metadata -module Hakyll.Core.ResourceProvider.Metadata - ( loadMetadata - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative -import Control.Arrow (second) -import qualified Data.ByteString.Char8 as BC -import qualified Data.Map as M -import System.IO as IO -import Text.Parsec (()) -import qualified Text.Parsec as P -import Text.Parsec.String (Parser) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Metadata -import Hakyll.Core.ResourceProvider.Internal -import Hakyll.Core.Util.String - - --------------------------------------------------------------------------------- -loadMetadata :: ResourceProvider -> Identifier -> IO (Metadata, Maybe String) -loadMetadata rp identifier = do - hasHeader <- probablyHasMetadataHeader fp - (md, body) <- if hasHeader - then second Just <$> loadMetadataHeader fp - else return (M.empty, Nothing) - - emd <- if resourceExists rp mi then loadMetadataFile mfp else return M.empty - - return (M.union md emd, body) - where - fp = toFilePath identifier - mi = resourceMetadataResource identifier - mfp = toFilePath mi - - --------------------------------------------------------------------------------- -loadMetadataHeader :: FilePath -> IO (Metadata, String) -loadMetadataHeader fp = do - contents <- readFile fp - case P.parse page fp contents of - Left err -> error (show err) - Right (md, b) -> return (M.fromList md, b) - - --------------------------------------------------------------------------------- -loadMetadataFile :: FilePath -> IO Metadata -loadMetadataFile fp = do - contents <- readFile fp - case P.parse metadata fp contents of - Left err -> error (show err) - Right md -> return $ M.fromList md - - --------------------------------------------------------------------------------- --- | Check if a file "probably" has a metadata header. The main goal of this is --- to exclude binary files (which are unlikely to start with "---"). -probablyHasMetadataHeader :: FilePath -> IO Bool -probablyHasMetadataHeader fp = do - handle <- IO.openFile fp IO.ReadMode - bs <- BC.hGet handle 1024 - IO.hClose handle - return $ isMetadataHeader bs - where - isMetadataHeader bs = - let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs - in BC.length pre >= 3 && BC.all (== '-') pre - - --------------------------------------------------------------------------------- --- | Space or tab, no newline -inlineSpace :: Parser Char -inlineSpace = P.oneOf ['\t', ' '] "space" - - --------------------------------------------------------------------------------- --- | Parse Windows newlines as well (i.e. "\n" or "\r\n") -newline :: Parser String -newline = P.string "\n" <|> P.string "\r\n" - - --------------------------------------------------------------------------------- --- | Parse a single metadata field -metadataField :: Parser (String, String) -metadataField = do - key <- P.manyTill P.alphaNum $ P.char ':' - P.skipMany1 inlineSpace "space followed by metadata for: " ++ key - value <- P.manyTill P.anyChar newline - trailing' <- P.many trailing - return (key, trim $ value ++ concat trailing') - where - trailing = (++) <$> P.many1 inlineSpace <*> P.manyTill P.anyChar newline - - --------------------------------------------------------------------------------- --- | Parse a metadata block -metadata :: Parser [(String, String)] -metadata = P.many metadataField - - --------------------------------------------------------------------------------- --- | Parse a metadata block, including delimiters and trailing newlines -metadataBlock :: Parser [(String, String)] -metadataBlock = do - open <- P.many1 (P.char '-') <* P.many inlineSpace <* newline - metadata' <- metadata - _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.'] - P.skipMany inlineSpace - P.skipMany1 newline - return metadata' - - --------------------------------------------------------------------------------- --- | Parse a page consisting of a metadata header and a body -page :: Parser ([(String, String)], String) -page = do - metadata' <- P.option [] metadataBlock - body <- P.many P.anyChar - return (metadata', body) diff --git a/src/Hakyll/Core/ResourceProvider/MetadataCache.hs b/src/Hakyll/Core/ResourceProvider/MetadataCache.hs deleted file mode 100644 index 959cdde..0000000 --- a/src/Hakyll/Core/ResourceProvider/MetadataCache.hs +++ /dev/null @@ -1,62 +0,0 @@ --------------------------------------------------------------------------------- -module Hakyll.Core.ResourceProvider.MetadataCache - ( resourceMetadata - , resourceBody - , resourceInvalidateMetadataCache - ) where - - --------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.Metadata -import Hakyll.Core.ResourceProvider.Internal -import Hakyll.Core.ResourceProvider.Metadata -import qualified Hakyll.Core.Store as Store - - --------------------------------------------------------------------------------- -resourceMetadata :: ResourceProvider -> Identifier -> IO Metadata -resourceMetadata rp r = do - load rp r - Store.Found md <- Store.get (resourceStore rp) - [name, toFilePath r, "metadata"] - return md - - --------------------------------------------------------------------------------- -resourceBody :: ResourceProvider -> Identifier -> IO String -resourceBody rp r = do - load rp r - Store.Found bd <- Store.get (resourceStore rp) - [name, toFilePath r, "body"] - maybe (resourceString r) return bd - - --------------------------------------------------------------------------------- -resourceInvalidateMetadataCache :: ResourceProvider -> Identifier -> IO () -resourceInvalidateMetadataCache rp r = do - Store.delete (resourceStore rp) [name, toFilePath r, "metadata"] - Store.delete (resourceStore rp) [name, toFilePath r, "body"] - - --------------------------------------------------------------------------------- -load :: ResourceProvider -> Identifier -> IO () -load rp r = do - mmd <- Store.get store mdk :: IO (Store.Result Metadata) - case mmd of - -- Already loaded - Store.Found _ -> return () - -- Not yet loaded - _ -> do - (metadata, body) <- loadMetadata rp r - Store.set store mdk metadata - Store.set store bk body - where - store = resourceStore rp - mdk = [name, toFilePath r, "metadata"] - bk = [name, toFilePath r, "body"] - - --------------------------------------------------------------------------------- -name :: String -name = "Hakyll.Core.Resource.Provider.MetadataCache" diff --git a/src/Hakyll/Core/ResourceProvider/Modified.hs b/src/Hakyll/Core/ResourceProvider/Modified.hs deleted file mode 100644 index 761f13c..0000000 --- a/src/Hakyll/Core/ResourceProvider/Modified.hs +++ /dev/null @@ -1,83 +0,0 @@ --------------------------------------------------------------------------------- -module Hakyll.Core.ResourceProvider.Modified - ( resourceModified - , resourceModificationTime - ) where - - --------------------------------------------------------------------------------- -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.IORef -import qualified Data.Map as M -import Data.Time (UTCTime) -import System.Directory (getModificationTime) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Identifier -import Hakyll.Core.ResourceProvider.Internal -import Hakyll.Core.ResourceProvider.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 :: ResourceProvider -> Identifier -> IO Bool -resourceModified rp 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 <- (||) - <$> fileDigestModified store (toFilePath r) - <*> resourceModified rp (resourceMetadataResource r) - modifyIORef cacheRef (M.insert normalized m) - - -- Important! (But ugly) - when m $ resourceInvalidateMetadataCache rp r - - return m - where - normalized = setVersion Nothing r - exists = resourceExists rp r - store = resourceStore rp - cacheRef = resourceModifiedCache rp - - --------------------------------------------------------------------------------- --- | 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 - -- All is fine, not modified - then return False - -- Resource modified; store new digest - else do - Store.set store key newDigest - 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 :: Identifier -> IO UTCTime -resourceModificationTime = getModificationTime . toFilePath diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 24b65dd..d9dea01 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -44,11 +44,12 @@ import Data.Typeable (Typeable) -------------------------------------------------------------------------------- -import Hakyll.Core.CompiledItem import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Item +import Hakyll.Core.Item.SomeItem +import Hakyll.Core.Provider import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal import Hakyll.Core.Writable @@ -63,11 +64,11 @@ tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty -------------------------------------------------------------------------------- -- | Add a number of compilers tellCompilers :: (Binary a, Typeable a, Writable a) - => [(Identifier, Compiler a)] + => [(Identifier, Compiler (Item a))] -> Rules () tellCompilers compilers = Rules $ do -- We box the compilers so they have a more simple type - let compilers' = map (second $ fmap compiledItem) compilers + let compilers' = map (second $ fmap SomeItem) compilers tell $ RuleSet mempty compilers' mempty @@ -132,7 +133,7 @@ group g = Rules . local setVersion' . unRules -- no resources match the current selection, nothing will happen. In this case, -- you might want to have a look at 'create'. compile :: (Binary a, Typeable a, Writable a) - => Compiler a -> Rules () + => Compiler (Item a) -> Rules () compile compiler = do ids <- resources tellCompilers [(id', compiler) | id' <- ids] @@ -149,7 +150,7 @@ compile compiler = do -- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been -- used). create :: (Binary a, Typeable a, Writable a) - => Identifier -> Compiler a -> Rules () + => Identifier -> Compiler (Item a) -> Rules () create id' compiler = Rules $ do version' <- rulesVersion <$> ask let id'' = setVersion version' id' @@ -175,9 +176,9 @@ route route' = Rules $ do -- the correct group to the identifiers. resources :: Rules [Identifier] resources = Rules $ do - pattern <- rulesPattern <$> ask - provider <- rulesResourceProvider <$> ask - g <- rulesVersion <$> ask + pattern <- rulesPattern <$> ask + provider <- rulesProvider <$> ask + g <- rulesVersion <$> ask return $ filterMatches pattern $ map (setVersion g) $ resourceList provider diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 360293f..a067b02 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -20,11 +20,11 @@ import Data.Set (Set) -------------------------------------------------------------------------------- -import Hakyll.Core.CompiledItem import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Item.SomeItem +import Hakyll.Core.Provider import Hakyll.Core.Routes @@ -34,7 +34,7 @@ data RuleSet = RuleSet { -- | Routes used in the compilation structure rulesRoutes :: Routes , -- | Compilation rules - rulesCompilers :: [(Identifier, Compiler CompiledItem)] + rulesCompilers :: [(Identifier, Compiler SomeItem)] , -- | A set of the actually used files rulesResources :: Set Identifier } @@ -57,9 +57,9 @@ data RuleState = RuleState -------------------------------------------------------------------------------- -- | Rule environment data RuleEnvironment = RuleEnvironment - { rulesResourceProvider :: ResourceProvider - , rulesPattern :: Pattern - , rulesVersion :: Maybe String + { rulesProvider :: Provider + , rulesPattern :: Pattern + , rulesVersion :: Maybe String } @@ -72,16 +72,16 @@ newtype Rules a = Rules -------------------------------------------------------------------------------- -- | Run a Rules monad, resulting in a 'RuleSet' -runRules :: Rules a -> ResourceProvider -> IO RuleSet +runRules :: Rules a -> Provider -> IO RuleSet runRules rules provider = do (_, _, ruleSet) <- runRWST (unRules rules) env state return $ nubCompilers ruleSet where state = RuleState {rulesNextIdentifier = 0} env = RuleEnvironment - { rulesResourceProvider = provider - , rulesPattern = mempty - , rulesVersion = Nothing + { rulesProvider = provider + , rulesPattern = mempty + , rulesVersion = Nothing } diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs index a66e4b5..d219252 100644 --- a/src/Hakyll/Core/Runtime.hs +++ b/src/Hakyll/Core/Runtime.hs @@ -22,15 +22,16 @@ import System.FilePath (()) -------------------------------------------------------------------------------- -import Hakyll.Core.CompiledItem import Hakyll.Core.Compiler.Internal import Hakyll.Core.Compiler.Require import Hakyll.Core.Configuration import Hakyll.Core.Dependencies import Hakyll.Core.Identifier +import Hakyll.Core.Item +import Hakyll.Core.Item.SomeItem import Hakyll.Core.Logger (Logger) import qualified Hakyll.Core.Logger as Logger -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Provider import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal import Hakyll.Core.Store (Store) @@ -49,7 +50,7 @@ run configuration rules = do store <- Store.new (inMemoryCache configuration) $ storeDirectory configuration Logger.message logger "Creating provider..." - provider <- newResourceProvider store (ignoreFile configuration) "." + provider <- newProvider store (ignoreFile configuration) "." Logger.message logger "Running rules..." ruleSet <- runRules rules provider @@ -94,17 +95,17 @@ run configuration rules = do data RuntimeRead = RuntimeRead { runtimeConfiguration :: Configuration , runtimeLogger :: Logger - , runtimeProvider :: ResourceProvider + , runtimeProvider :: Provider , runtimeStore :: Store , runtimeRoutes :: Routes - , runtimeUniverse :: [(Identifier, Compiler CompiledItem)] + , runtimeUniverse :: [(Identifier, Compiler SomeItem)] } -------------------------------------------------------------------------------- data RuntimeState = RuntimeState { runtimeDone :: Set Identifier - , runtimeTodo :: Map Identifier (Compiler CompiledItem) + , runtimeTodo :: Map Identifier (Compiler SomeItem) , runtimeFacts :: DependencyFacts } @@ -178,7 +179,7 @@ chase trail id' let compiler = todo M.! id' read' = CompilerRead - { compilerIdentifier = id' + { compilerUnderlying = id' , compilerProvider = provider , compilerUniverse = map fst universe , compilerRoutes = routes @@ -192,8 +193,10 @@ chase trail id' CompilerError e -> throwError e -- Huge success - CompilerDone (CompiledItem compiled) cwrite -> do - let facts = compilerDependencies cwrite + CompilerDone (SomeItem item) cwrite -> do + -- TODO: Sanity check on itemIdentifier? + let body = itemBody item + facts = compilerDependencies cwrite cacheHits | compilerCacheHits cwrite <= 0 = "updated" | otherwise = "cached " @@ -207,11 +210,11 @@ chase trail id' Just url -> do let path = destinationDirectory config url liftIO $ makeDirectories path - liftIO $ write path compiled + liftIO $ write path item Logger.debug logger $ "Routed to " ++ path -- Save! (For require) - liftIO $ save store id' compiled + liftIO $ save store id' body -- Update state modify $ \s -> s diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs index c37c630..cad6cf1 100644 --- a/src/Hakyll/Core/Writable.hs +++ b/src/Hakyll/Core/Writable.hs @@ -1,42 +1,56 @@ +-------------------------------------------------------------------------------- -- | Describes writable items; items that can be saved to the disk --- -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module Hakyll.Core.Writable ( Writable (..) ) where -import Data.Word (Word8) -import qualified Data.ByteString as SB -import qualified Data.ByteString.Lazy as LB -import Text.Blaze.Html (Html) -import Text.Blaze.Html.Renderer.String (renderHtml) +-------------------------------------------------------------------------------- +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Word (Word8) +import Text.Blaze.Html (Html) +import Text.Blaze.Html.Renderer.String (renderHtml) -import Hakyll.Core.Identifier +-------------------------------------------------------------------------------- +import Hakyll.Core.Item + + +-------------------------------------------------------------------------------- -- | Describes an item that can be saved to the disk --- class Writable a where -- | Save an item to the given filepath - write :: FilePath -> a -> IO () + write :: FilePath -> Item a -> IO () + +-------------------------------------------------------------------------------- instance Writable () where write _ _ = return () + +-------------------------------------------------------------------------------- instance Writable [Char] where - write = writeFile + write p = writeFile p . itemBody + +-------------------------------------------------------------------------------- instance Writable SB.ByteString where - write p = SB.writeFile p + write p = SB.writeFile p . itemBody + +-------------------------------------------------------------------------------- instance Writable LB.ByteString where - write p = LB.writeFile p + write p = LB.writeFile p . itemBody + +-------------------------------------------------------------------------------- instance Writable [Word8] where - write p = write p . SB.pack + write p = write p . fmap SB.pack -instance Writable Html where - write p html = write p $ renderHtml html -instance Writable Identifier where - write p = write p . show +-------------------------------------------------------------------------------- +instance Writable Html where + write p = write p . fmap renderHtml diff --git a/src/Hakyll/Core/Writable/CopyFile.hs b/src/Hakyll/Core/Writable/CopyFile.hs index 2d92891..58397ac 100644 --- a/src/Hakyll/Core/Writable/CopyFile.hs +++ b/src/Hakyll/Core/Writable/CopyFile.hs @@ -9,8 +9,7 @@ module Hakyll.Core.Writable.CopyFile -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Data.Binary (Binary) +import Data.Binary (Binary (..)) import Data.Typeable (Typeable) import System.Directory (copyFile) @@ -18,20 +17,27 @@ import System.Directory (copyFile) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier +import Hakyll.Core.Item import Hakyll.Core.Writable -------------------------------------------------------------------------------- --- | Newtype construct around 'FilePath' which will copy the file directly -newtype CopyFile = CopyFile {unCopyFile :: FilePath} - deriving (Show, Eq, Ord, Binary, Typeable) +-- | This will copy any file directly by using a system call +data CopyFile = CopyFile + deriving (Show, Eq, Ord, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary CopyFile where + put CopyFile = return () + get = return CopyFile -------------------------------------------------------------------------------- instance Writable CopyFile where - write dst (CopyFile src) = copyFile src dst + write dst item = copyFile (toFilePath $ itemIdentifier item) dst -------------------------------------------------------------------------------- -copyFileCompiler :: Compiler CopyFile -copyFileCompiler = CopyFile . toFilePath <$> getIdentifier +copyFileCompiler :: Compiler (Item CopyFile) +copyFileCompiler = makeItem CopyFile diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs index 133c7f0..f3290f3 100644 --- a/src/Hakyll/Web/CompressCss.hs +++ b/src/Hakyll/Web/CompressCss.hs @@ -15,13 +15,14 @@ import Data.List (isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Item import Hakyll.Core.Util.String -------------------------------------------------------------------------------- -- | Compiler form of 'compressCss' -compressCssCompiler :: Compiler String -compressCssCompiler = compressCss <$> getResourceString +compressCssCompiler :: Compiler (Item String) +compressCssCompiler = fmap compressCss <$> getResourceString -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index ca98042..f58f948 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -49,34 +49,26 @@ -- contains three metadata fields and a body. The body is given in markdown -- format, which can be easily rendered to HTML by Hakyll, using pandoc. module Hakyll.Web.Page - ( Page - , readPageCompiler - , pageCompiler + ( pageCompiler , pageCompilerWith , pageCompilerWithPandoc ) where -------------------------------------------------------------------------------- -import Text.Pandoc (Pandoc, ParserState, WriterOptions) +import Control.Applicative ((<$>)) +import Text.Pandoc (Pandoc, ParserState, WriterOptions) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler -import Hakyll.Web.Page.Internal +import Hakyll.Core.Item import Hakyll.Web.Pandoc --------------------------------------------------------------------------------- --- | Read a page (do not render it) -readPageCompiler :: Compiler Page -readPageCompiler = getResourceBody -{-# DEPRECATED readPageCompiler "Use getResourceBody" #-} - - -------------------------------------------------------------------------------- -- | Read a page render using pandoc -pageCompiler :: Compiler Page +pageCompiler :: Compiler (Item String) pageCompiler = pageCompilerWith defaultHakyllParserState defaultHakyllWriterOptions @@ -84,7 +76,7 @@ pageCompiler = -------------------------------------------------------------------------------- -- | A version of 'pageCompiler' which allows you to specify your own pandoc -- options -pageCompilerWith :: ParserState -> WriterOptions -> Compiler Page +pageCompilerWith :: ParserState -> WriterOptions -> Compiler (Item String) pageCompilerWith state options = pageCompilerWithPandoc state options id @@ -93,9 +85,8 @@ pageCompilerWith state options = pageCompilerWithPandoc state options id -- pandoc transformation for the content pageCompilerWithPandoc :: ParserState -> WriterOptions -> (Pandoc -> Pandoc) - -> Compiler Page + -> Compiler (Item String) pageCompilerWithPandoc state options f = cached cacheName $ - readPageCompiler >>= pageReadPandocWith state >>= - return . writePandocWith options . f + writePandocWith options . fmap f . readPandocWith state <$> getResourceBody where cacheName = "Hakyll.Web.Page.pageCompilerWithPandoc" diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs deleted file mode 100644 index 04cf08a..0000000 --- a/src/Hakyll/Web/Page/Internal.hs +++ /dev/null @@ -1,8 +0,0 @@ --------------------------------------------------------------------------------- -module Hakyll.Web.Page.Internal - ( Page - ) where - - --------------------------------------------------------------------------------- -type Page = String diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index caada26..c2319dc 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -6,12 +6,8 @@ module Hakyll.Web.Pandoc , readPandocWith , writePandoc , writePandocWith - - -- * Functions working on pages/compilers - , pageReadPandoc - , pageReadPandocWith - , pageRenderPandoc - , pageRenderPandocWith + , renderPandoc + , renderPandocWith -- * Default options , defaultHakyllParserState @@ -20,89 +16,66 @@ module Hakyll.Web.Pandoc -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Data.Maybe (fromMaybe) import Text.Pandoc -------------------------------------------------------------------------------- -import Hakyll.Core.Compiler -import Hakyll.Core.Identifier -import Hakyll.Web.Page.Internal +import Hakyll.Core.Item import Hakyll.Web.Pandoc.FileType -------------------------------------------------------------------------------- -- | Read a string using pandoc, with the default options -readPandoc :: FileType -- ^ Determines how parsing happens - -> Maybe Identifier -- ^ Optional, for better error messages - -> Page -- ^ String to read - -> Pandoc -- ^ Resulting document +readPandoc :: Item String -- ^ String to read + -> Item Pandoc -- ^ Resulting document readPandoc = readPandocWith defaultHakyllParserState -------------------------------------------------------------------------------- -- | Read a string using pandoc, with the supplied options -readPandocWith :: ParserState -- ^ Parser options - -> FileType -- ^ Determines parsing method - -> Maybe Identifier -- ^ Optional, for better error messages - -> Page -- ^ String to read - -> Pandoc -- ^ Resulting document -readPandocWith state fileType' id' = case fileType' of - Html -> readHtml state - LaTeX -> readLaTeX state - LiterateHaskell t -> - readPandocWith state {stateLiterateHaskell = True} t id' - Markdown -> readMarkdown state - Rst -> readRST state - Textile -> readTextile state - t -> error $ - "Hakyll.Web.readPandocWith: I don't know how to read a file of the " ++ - "type " ++ show t ++ fromMaybe "" (fmap ((" for: " ++) . show) id') +readPandocWith :: ParserState -- ^ Parser options + -> Item String -- ^ String to read + -> Item Pandoc -- ^ Resulting document +readPandocWith state item = fmap (reader state (itemFileType item)) item + where + reader s t = case t of + Html -> readHtml s + LaTeX -> readLaTeX s + LiterateHaskell t' -> reader s {stateLiterateHaskell = True} t' + Markdown -> readMarkdown s + Rst -> readRST s + Textile -> readTextile s + _ -> error $ + "Hakyll.Web.readPandocWith: I don't know how to read a file of the " ++ + "type " ++ show t ++ " for: " ++ show (itemIdentifier item) -------------------------------------------------------------------------------- -- | Write a document (as HTML) using pandoc, with the default options -writePandoc :: Pandoc -- ^ Document to write - -> Page -- ^ Resulting HTML +writePandoc :: Item Pandoc -- ^ Document to write + -> Item String -- ^ Resulting HTML writePandoc = writePandocWith defaultHakyllWriterOptions -------------------------------------------------------------------------------- -- | Write a document (as HTML) using pandoc, with the supplied options writePandocWith :: WriterOptions -- ^ Writer options for pandoc - -> Pandoc -- ^ Document to write - -> Page -- ^ Resulting HTML -writePandocWith = writeHtmlString - - --------------------------------------------------------------------------------- --- | Read the resource using pandoc -pageReadPandoc :: Page -> Compiler Pandoc -pageReadPandoc = pageReadPandocWith defaultHakyllParserState - - --------------------------------------------------------------------------------- --- | Read the resource using pandoc -pageReadPandocWith :: ParserState -> Page -> Compiler Pandoc -pageReadPandocWith state page = do - identifier <- getIdentifier - fileType' <- getFileType - return $ readPandocWith state fileType' (Just identifier) page + -> Item Pandoc -- ^ Document to write + -> Item String -- ^ Resulting HTML +writePandocWith options = fmap $ writeHtmlString options -------------------------------------------------------------------------------- -- | Render the resource using pandoc -pageRenderPandoc :: Page -> Compiler Page -pageRenderPandoc = - pageRenderPandocWith defaultHakyllParserState defaultHakyllWriterOptions +renderPandoc :: Item String -> Item String +renderPandoc = + renderPandocWith defaultHakyllParserState defaultHakyllWriterOptions -------------------------------------------------------------------------------- -- | Render the resource using pandoc -pageRenderPandocWith :: ParserState -> WriterOptions -> Page -> Compiler Page -pageRenderPandocWith state options page = - writePandocWith options <$> pageReadPandocWith state page +renderPandocWith :: ParserState -> WriterOptions -> Item String -> Item String +renderPandocWith state options = writePandocWith options . readPandocWith state -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs index ca8d10e..8c284a0 100644 --- a/src/Hakyll/Web/Pandoc/Biblio.hs +++ b/src/Hakyll/Web/Pandoc/Biblio.hs @@ -15,7 +15,7 @@ module Hakyll.Web.Pandoc.Biblio , cslCompiler , Biblio (..) , biblioCompiler - , pageReadPandocBiblio + , readPandocBiblio ) where @@ -31,19 +31,31 @@ import Text.Pandoc.Biblio (processBiblio) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier +import Hakyll.Core.Item import Hakyll.Core.Writable -import Hakyll.Web.Page import Hakyll.Web.Pandoc -------------------------------------------------------------------------------- -newtype CSL = CSL FilePath - deriving (Binary, Show, Typeable, Writable) +data CSL = CSL + deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary CSL where + put CSL = return () + get = return CSL + + +-------------------------------------------------------------------------------- +instance Writable CSL where + -- Shouldn't be written. + write _ _ = return () -------------------------------------------------------------------------------- -cslCompiler :: Compiler CSL -cslCompiler = CSL . toFilePath <$> getIdentifier +cslCompiler :: Compiler (Item CSL) +cslCompiler = makeItem CSL -------------------------------------------------------------------------------- @@ -57,29 +69,34 @@ instance Binary Biblio where get = Biblio . read <$> get put (Biblio rs) = put $ show rs + +-------------------------------------------------------------------------------- instance Writable Biblio where + -- Shouldn't be written. write _ _ = return () -------------------------------------------------------------------------------- -biblioCompiler :: Compiler Biblio +biblioCompiler :: Compiler (Item Biblio) biblioCompiler = do - filePath <- toFilePath <$> getIdentifier - unsafeCompiler $ Biblio <$> CSL.readBiblioFile filePath + filePath <- toFilePath <$> getUnderlying + makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath) -------------------------------------------------------------------------------- -pageReadPandocBiblio :: ParserState - -> CSL - -> Biblio - -> Page - -> Compiler Pandoc -pageReadPandocBiblio state (CSL csl) (Biblio refs) page = do +readPandocBiblio :: ParserState + -> Item CSL + -> Item Biblio + -> (Item String) + -> Compiler (Item Pandoc) +readPandocBiblio state csl biblio item = do -- We need to know the citation keys, add then *before* actually parsing the -- actual page. If we don't do this, pandoc won't even consider them -- citations! - let cits = map CSL.refId refs - state' = state {stateCitations = stateCitations state ++ cits} - pandoc <- pageReadPandocWith state' page - pandoc' <- unsafeCompiler $ processBiblio csl Nothing refs pandoc - return pandoc' + let Biblio refs = itemBody biblio + cits = map CSL.refId refs + state' = state {stateCitations = stateCitations state ++ cits} + pandoc = itemBody $ readPandocWith state' item + cslPath = toFilePath $ itemIdentifier csl + pandoc' <- unsafeCompiler $ processBiblio cslPath Nothing refs pandoc + return $ fmap (const pandoc') item diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs index 2d28edd..1ae4c10 100644 --- a/src/Hakyll/Web/Pandoc/FileType.hs +++ b/src/Hakyll/Web/Pandoc/FileType.hs @@ -3,18 +3,17 @@ module Hakyll.Web.Pandoc.FileType ( FileType (..) , fileType - , getFileType + , itemFileType ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) import System.FilePath (takeExtension) -------------------------------------------------------------------------------- -import Hakyll.Core.Compiler import Hakyll.Core.Identifier +import Hakyll.Core.Item -------------------------------------------------------------------------------- @@ -62,5 +61,5 @@ fileType = fileType' . takeExtension -------------------------------------------------------------------------------- -- | Get the file type for the current file -getFileType :: Compiler FileType -getFileType = fileType . toFilePath <$> getIdentifier +itemFileType :: Item a -> FileType +itemFileType = fileType . toFilePath . itemIdentifier diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 6d9060f..adaf1aa 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -60,10 +60,10 @@ -- > #{body} module Hakyll.Web.Template ( Template - , applyTemplate , templateCompiler , templateCompilerWith - , applyTemplateCompiler + , applyTemplate + , applyTemplateWith ) where @@ -78,51 +78,51 @@ import Text.Hamlet (HamletSettings, -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier -import Hakyll.Web.Page.Internal +import Hakyll.Core.Item import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal import Hakyll.Web.Template.Read --------------------------------------------------------------------------------- -applyTemplate :: Monad m - => (String -> a -> m String) - -> Template -> a -> m String -applyTemplate context tpl x = liftM concat $ - forM (unTemplate tpl) $ \e -> case e of - Chunk c -> return c - Escaped -> return "$" - Key k -> context k x - - -------------------------------------------------------------------------------- -- | Read a template. If the extension of the file we're compiling is -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. -templateCompiler :: Compiler Template +templateCompiler :: Compiler (Item Template) templateCompiler = templateCompilerWith defaultHamletSettings -------------------------------------------------------------------------------- -- | Version of 'templateCompiler' that enables custom settings. -templateCompilerWith :: HamletSettings -> Compiler Template +templateCompilerWith :: HamletSettings -> Compiler (Item Template) templateCompilerWith settings = cached "Hakyll.Web.Template.templateCompilerWith" $ do - identifier <- getIdentifier - string <- getResourceString + identifier <- getUnderlying + item <- getResourceString if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"] -- Hamlet template - then return $ readHamletTemplateWith settings string + then return $ fmap (readHamletTemplateWith settings) item -- Hakyll template - else return $ readTemplate string + else return $ fmap readTemplate item + + +-------------------------------------------------------------------------------- +applyTemplate :: Template -- ^ Template + -> Context a -- ^ Context + -> Item a -- ^ Page + -> Compiler (Item String) -- ^ Resulting item +applyTemplate tpl context item = do + let context' k x = unContext context k x + body <- applyTemplateWith context' tpl item + return $ itemSetBody body item -------------------------------------------------------------------------------- -applyTemplateCompiler :: Template -- ^ Template - -> Context Page -- ^ Context - -> Page -- ^ Page - -> Compiler Page -- ^ Compiler -applyTemplateCompiler tpl context page = do - identifier <- getIdentifier - let context' k x = unContext context k identifier x - applyTemplate context' tpl page +applyTemplateWith :: Monad m + => (String -> a -> m String) + -> Template -> a -> m String +applyTemplateWith context tpl x = liftM concat $ + forM (unTemplate tpl) $ \e -> case e of + Chunk c -> return c + Escaped -> return "$" + Key k -> context k x diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index 2ef82e9..b3c2a6d 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -34,36 +34,36 @@ import System.Locale (TimeLocale, defaultTimeLocale) import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier -import Hakyll.Core.ResourceProvider +import Hakyll.Core.Item +import Hakyll.Core.Provider import Hakyll.Core.Util.String (splitAll) -import Hakyll.Web.Page.Internal import Hakyll.Web.Urls -------------------------------------------------------------------------------- newtype Context a = Context - { unContext :: String -> Identifier -> a -> Compiler String + { unContext :: String -> Item a -> Compiler String } -------------------------------------------------------------------------------- instance Monoid (Context a) where - mempty = Context $ \_ _ _ -> empty - mappend (Context f) (Context g) = Context $ \k i x -> f k i x <|> g k i x + mempty = Context $ \_ _ -> empty + mappend (Context f) (Context g) = Context $ \k i -> f k i <|> g k i -------------------------------------------------------------------------------- mapContext :: (String -> String) -> Context a -> Context a -mapContext f (Context g) = Context $ \k i x -> f <$> g k i x +mapContext f (Context g) = Context $ \k i -> f <$> g k i -------------------------------------------------------------------------------- -field :: String -> (Identifier -> a -> Compiler String) -> Context a -field key value = Context $ \k i x -> if k == key then value i x else empty +field :: String -> (Item a -> Compiler String) -> Context a +field key value = Context $ \k i -> if k == key then value i else empty -------------------------------------------------------------------------------- -defaultContext :: Context Page +defaultContext :: Context String defaultContext = bodyField "body" `mappend` urlField "url" `mappend` @@ -74,18 +74,19 @@ defaultContext = -------------------------------------------------------------------------------- -bodyField :: String -> Context Page -bodyField key = field key $ \_ x -> return x +bodyField :: String -> Context String +bodyField key = field key $ return . itemBody -------------------------------------------------------------------------------- urlField :: String -> Context a -urlField key = field key $ \i _ -> maybe empty toUrl <$> getRouteFor i +urlField key = field key $ + fmap (maybe empty toUrl) . getRoute . itemIdentifier -------------------------------------------------------------------------------- pathField :: String -> Context a -pathField key = field key $ \i _ -> return $ toFilePath i +pathField key = field key $ return . toFilePath . itemIdentifier -------------------------------------------------------------------------------- @@ -133,8 +134,8 @@ dateFieldWith :: TimeLocale -- ^ Output time locale -> String -- ^ Destination key -> String -- ^ Format to use on the date -> Context a -- ^ Resulting context -dateFieldWith locale key format = field key $ \id' _ -> do - time <- getUTC locale id' +dateFieldWith locale key format = field key $ \i -> do + time <- getUTC locale $ itemIdentifier i return $ formatTime locale format time @@ -145,7 +146,7 @@ getUTC :: TimeLocale -- ^ Output time locale -> Identifier -- ^ Input page -> Compiler UTCTime -- ^ Parsed UTCTime getUTC locale id' = do - metadata <- getMetadataFor id' + metadata <- getMetadata id' let tryField k fmt = M.lookup k metadata >>= parseTime' fmt fn = takeFileName $ toFilePath id' @@ -177,11 +178,11 @@ modificationTimeFieldWith :: TimeLocale -- ^ Time output locale -> String -- ^ Key -> String -- ^ Format -> Context a -- ^ Resulting context -modificationTimeFieldWith locale key fmt = field key $ \id' _ -> do - mtime <- compilerUnsafeIO $ resourceModificationTime id' +modificationTimeFieldWith locale key fmt = field key $ \i -> do + mtime <- compilerUnsafeIO $ resourceModificationTime $ itemIdentifier i return $ formatTime locale fmt mtime -------------------------------------------------------------------------------- missingField :: Context a -missingField = Context $ \k _ _ -> return $ "$" ++ k ++ "$" +missingField = Context $ \k _ -> return $ "$" ++ k ++ "$" diff --git a/src/Hakyll/Web/Urls/Relativize.hs b/src/Hakyll/Web/Urls/Relativize.hs index 068ae09..321bbe3 100644 --- a/src/Hakyll/Web/Urls/Relativize.hs +++ b/src/Hakyll/Web/Urls/Relativize.hs @@ -15,8 +15,8 @@ -- -- > Funny zomgroflcopter module Hakyll.Web.Urls.Relativize - ( relativizeUrlsCompiler - , relativizeUrls + ( relativizeUrls + , relativizeUrlsWith ) where @@ -26,27 +26,27 @@ import Data.List (isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler -import Hakyll.Web.Page +import Hakyll.Core.Item import Hakyll.Web.Urls -------------------------------------------------------------------------------- -- | Compiler form of 'relativizeUrls' which automatically picks the right root -- path -relativizeUrlsCompiler :: Page -> Compiler Page -relativizeUrlsCompiler page = do - route <- getRoute +relativizeUrls :: Item String -> Compiler (Item String) +relativizeUrls item = do + route <- getRoute $ itemIdentifier item return $ case route of - Nothing -> page - Just r -> relativizeUrls (toSiteRoot r) page + Nothing -> item + Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item -------------------------------------------------------------------------------- -- | Relativize URL's in HTML -relativizeUrls :: String -- ^ Path to the site root - -> Page -- ^ HTML to relativize - -> Page -- ^ Resulting HTML -relativizeUrls root = withUrls rel +relativizeUrlsWith :: String -- ^ Path to the site root + -> String -- ^ HTML to relativize + -> String -- ^ Resulting HTML +relativizeUrlsWith root = withUrls rel where isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x) rel x = if isRel x then root ++ x else x -- cgit v1.2.3