diff options
Diffstat (limited to 'lib/Hakyll/Core/Provider')
| -rw-r--r-- | lib/Hakyll/Core/Provider/Internal.hs | 202 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Provider/Metadata.hs | 151 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Provider/MetadataCache.hs | 62 |
3 files changed, 415 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Provider/Internal.hs b/lib/Hakyll/Core/Provider/Internal.hs new file mode 100644 index 0000000..c298653 --- /dev/null +++ b/lib/Hakyll/Core/Provider/Internal.hs @@ -0,0 +1,202 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Core.Provider.Internal + ( ResourceInfo (..) + , Provider (..) + , newProvider + + , resourceList + , resourceExists + + , resourceFilePath + , resourceString + , resourceLBS + + , resourceModified + , resourceModificationTime + ) where + + +-------------------------------------------------------------------------------- +import Control.DeepSeq (NFData (..), deepseq) +import Control.Monad (forM) +import Data.Binary (Binary (..)) +import qualified Data.ByteString.Lazy as BL +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Time (Day (..), UTCTime (..)) +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 (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 (toRational dt) + + get = fmap BinaryTime $ UTCTime + <$> (ModifiedJulianDay <$> get) + <*> (fromRational <$> 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 + , -- | A list of all files found + providerFiles :: Map Identifier ResourceInfo + , -- | A list of the files from the previous run + providerOldFiles :: Map Identifier ResourceInfo + , -- | Underlying persistent store for caching + providerStore :: Store + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | Create a resource provider +newProvider :: Store -- ^ Store to use + -> (FilePath -> IO Bool) -- ^ Should we ignore this file? + -> FilePath -- ^ Search directory + -> IO Provider -- ^ Resulting provider +newProvider store ignore directory = do + 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 = M.keys . providerFiles + + +-------------------------------------------------------------------------------- +-- | Check if a given resource exists +resourceExists :: Provider -> Identifier -> Bool +resourceExists provider = + (`M.member` providerFiles provider) . setVersion Nothing + + +-------------------------------------------------------------------------------- +resourceFilePath :: Provider -> Identifier -> FilePath +resourceFilePath p i = providerDirectory p </> toFilePath i + + +-------------------------------------------------------------------------------- +-- | Get the raw body of a resource as string +resourceString :: Provider -> Identifier -> IO String +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, _) -> False + (Just _, Nothing) -> True + (Just n, Just o) -> + resourceInfoModified n > resourceInfoModified o || + resourceInfoMetadata n /= resourceInfoMetadata o + where + normal = setVersion Nothing r + ri = M.lookup normal (providerFiles p) + oldRi = M.lookup normal (providerOldFiles 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/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs new file mode 100644 index 0000000..6285ce1 --- /dev/null +++ b/lib/Hakyll/Core/Provider/Metadata.hs @@ -0,0 +1,151 @@ +-------------------------------------------------------------------------------- +-- | Internal module to parse metadata +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +module Hakyll.Core.Provider.Metadata + ( loadMetadata + , parsePage + + , MetadataException (..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow (second) +import Control.Exception (Exception, throwIO) +import Control.Monad (guard) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.List.Extended (breakWhen) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Yaml as Yaml +import Hakyll.Core.Identifier +import Hakyll.Core.Metadata +import Hakyll.Core.Provider.Internal +import System.IO as IO + + +-------------------------------------------------------------------------------- +loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String) +loadMetadata p identifier = do + hasHeader <- probablyHasMetadataHeader fp + (md, body) <- if hasHeader + then second Just <$> loadMetadataHeader fp + else return (mempty, Nothing) + + emd <- case mi of + Nothing -> return mempty + Just mi' -> loadMetadataFile $ resourceFilePath p mi' + + return (md <> emd, body) + where + normal = setVersion Nothing identifier + fp = resourceFilePath p identifier + mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata + + +-------------------------------------------------------------------------------- +loadMetadataHeader :: FilePath -> IO (Metadata, String) +loadMetadataHeader fp = do + fileContent <- readFile fp + case parsePage fileContent of + Right x -> return x + Left err -> throwIO $ MetadataException fp err + + +-------------------------------------------------------------------------------- +loadMetadataFile :: FilePath -> IO Metadata +loadMetadataFile fp = do + fileContent <- B.readFile fp + let errOrMeta = Yaml.decodeEither' fileContent + either (fail . show) return errOrMeta + + +-------------------------------------------------------------------------------- +-- | 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 + + +-------------------------------------------------------------------------------- +-- | Parse the page metadata and body. +splitMetadata :: String -> (Maybe String, String) +splitMetadata str0 = fromMaybe (Nothing, str0) $ do + guard $ leading >= 3 + let !str1 = drop leading str0 + guard $ all isNewline (take 1 str1) + let !(!meta, !content0) = breakWhen isTrailing str1 + guard $ not $ null content0 + let !content1 = drop (leading + 1) content0 + !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1 + -- Adding this newline fixes the line numbers reported by the YAML parser. + -- It's a bit ugly but it works. + return (Just ('\n' : meta), content2) + where + -- Parse the leading "---" + !leading = length $ takeWhile (== '-') str0 + + -- Predicate to recognize the trailing "---" or "..." + isTrailing [] = False + isTrailing (x : xs) = + isNewline x && length (takeWhile isDash xs) == leading + + -- Characters + isNewline c = c == '\n' || c == '\r' + isDash c = c == '-' || c == '.' + isInlineSpace c = c == '\t' || c == ' ' + + +-------------------------------------------------------------------------------- +parseMetadata :: String -> Either Yaml.ParseException Metadata +parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack + + +-------------------------------------------------------------------------------- +parsePage :: String -> Either Yaml.ParseException (Metadata, String) +parsePage fileContent = case mbMetaBlock of + Nothing -> return (mempty, content) + Just metaBlock -> case parseMetadata metaBlock of + Left err -> Left err + Right meta -> return (meta, content) + where + !(!mbMetaBlock, !content) = splitMetadata fileContent + + +-------------------------------------------------------------------------------- +-- | Thrown in the IO monad if things go wrong. Provides a nice-ish error +-- message. +data MetadataException = MetadataException FilePath Yaml.ParseException + + +-------------------------------------------------------------------------------- +instance Exception MetadataException + + +-------------------------------------------------------------------------------- +instance Show MetadataException where + show (MetadataException fp err) = + fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint + + where + hint = case err of + Yaml.InvalidYaml (Just (Yaml.YamlParseException {..})) + | yamlProblem == problem -> "\n" ++ + "Hint: if the metadata value contains characters such\n" ++ + "as ':' or '-', try enclosing it in quotes." + _ -> "" + + problem = "mapping values are not allowed in this context" diff --git a/lib/Hakyll/Core/Provider/MetadataCache.hs b/lib/Hakyll/Core/Provider/MetadataCache.hs new file mode 100644 index 0000000..46dbf3e --- /dev/null +++ b/lib/Hakyll/Core/Provider/MetadataCache.hs @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Provider.MetadataCache + ( resourceMetadata + , resourceBody + , resourceInvalidateMetadataCache + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (unless) +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 + | not (resourceExists p r) = return mempty + | otherwise = do + -- TODO keep time in md cache + load p r + Store.Found (BinaryMetadata 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 p 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 + mmof <- Store.isMember store mdk + unless mmof $ do + (md, body) <- loadMetadata p r + Store.set store mdk (BinaryMetadata md) + 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" |