yogsototh/hakyll
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial YAML support

Browse source 
See #225
This commit is contained in:
Jasper Van der Jeugt 2016-04-06 14:26:46 +02:00
parent 3f3e09672d
commit e81468e0f6
17 changed files with 287 additions and 195 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -1,4 +1,4 @@
# Ignore swap files and cabal output.
# Ignore swap files and stack/cabal output.
*.hi
*.o
*.swo
@ -10,6 +10,7 @@ dist
tags
cabal.sandbox.config
.cabal-sandbox/
.stack-work
# Ignore test builds.
tests/Main

14
hakyll.cabal
View file

@ -121,6 +121,8 @@ Library
Hakyll.Web.Template.List
Other-Modules:
Data.List.Extended
Data.Yaml.Extended
Hakyll.Check
Hakyll.Commands
Hakyll.Core.Compiler.Internal
@ -166,7 +168,10 @@ Library
tagsoup >= 0.13.1 && < 0.14,
text >= 0.11 && < 1.3,
time >= 1.4 && < 1.6,
time-locale-compat >= 0.1 && < 0.2
time-locale-compat >= 0.1 && < 0.2,
unordered-containers >= 0.2 && < 0.3,
vector >= 0.11 && < 0.12,
yaml >= 0.8 && < 0.9
If flag(previewServer)
Build-depends:
@ -251,8 +256,11 @@ Test-suite hakyll-tests
regex-tdfa >= 1.1 && < 1.3,
tagsoup >= 0.13.1 && < 0.14,
text >= 0.11 && < 1.3,
time >= 1.5 && < 1.6,
time-locale-compat >= 0.1 && < 0.2
time >= 1.4 && < 1.6,
time-locale-compat >= 0.1 && < 0.2,
unordered-containers >= 0.2 && < 0.3,
vector >= 0.11 && < 0.12,
yaml >= 0.8 && < 0.9
If flag(previewServer)
Build-depends:

15
src/Data/List/Extended.hs Normal file
View file

@ -0,0 +1,15 @@
module Data.List.Extended
( module Data.List
, breakWhen
) where
import Data.List
-- | Like 'break', but can act on the entire tail of the list.
breakWhen :: ([a] -> Bool) -> [a] -> ([a], [a])
breakWhen predicate = go []
where
go buf [] = (reverse buf, [])
go buf (x : xs)
| predicate (x : xs) = (reverse buf, x : xs)
| otherwise = go (x : buf) xs

17
src/Data/Yaml/Extended.hs Normal file
View file

@ -0,0 +1,17 @@
module Data.Yaml.Extended
( module Data.Yaml
, toString
, toList
) where
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Yaml
toString :: Value -> Maybe String
toString (String t) = Just (T.unpack t)
toString _ = Nothing
toList :: Value -> Maybe [Value]
toList (Array a) = Just (V.toList a)
toList _ = Nothing

88
src/Hakyll/Core/Metadata.hs
View file

@ -1,28 +1,46 @@
--------------------------------------------------------------------------------
module Hakyll.Core.Metadata
( Metadata
, lookupString
, lookupStringList
, MonadMetadata (..)
, getMetadataField
, getMetadataField'
, makePatternDependency
, BinaryMetadata (..)
) where
--------------------------------------------------------------------------------
import Control.Arrow (second)
import Control.Monad (forM)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Binary (Binary (..), getWord8,
putWord8, Get)
import qualified Data.HashMap.Strict as HMS
import qualified Data.Set as S
--------------------------------------------------------------------------------
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.Yaml.Extended as Yaml
import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
--------------------------------------------------------------------------------
type Metadata = Map String String
type Metadata = Yaml.Object
--------------------------------------------------------------------------------
lookupString :: String -> Metadata -> Maybe String
lookupString key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString
--------------------------------------------------------------------------------
lookupStringList :: String -> Metadata -> Maybe [String]
lookupStringList key meta =
HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString
--------------------------------------------------------------------------------
@ -42,7 +60,7 @@ class Monad m => MonadMetadata m where
getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
getMetadataField identifier key = do
metadata <- getMetadata identifier
return $ M.lookup key metadata
return $ lookupString key metadata
--------------------------------------------------------------------------------
@ -62,3 +80,59 @@ makePatternDependency :: MonadMetadata m => Pattern -> m Dependency
makePatternDependency pattern = do
matches' <- getMatches pattern
return $ PatternDependency pattern (S.fromList matches')
--------------------------------------------------------------------------------
-- | Newtype wrapper for serialization.
newtype BinaryMetadata = BinaryMetadata
{unBinaryMetadata :: Metadata}
instance Binary BinaryMetadata where
put (BinaryMetadata obj) = put (BinaryYaml $ Yaml.Object obj)
get = do
BinaryYaml (Yaml.Object obj) <- get
return $ BinaryMetadata obj
--------------------------------------------------------------------------------
newtype BinaryYaml = BinaryYaml {unBinaryYaml :: Yaml.Value}
--------------------------------------------------------------------------------
instance Binary BinaryYaml where
put (BinaryYaml yaml) = case yaml of
Yaml.Object obj -> do
putWord8 0
let list :: [(T.Text, BinaryYaml)]
list = map (second BinaryYaml) $ HMS.toList obj
put list
Yaml.Array arr -> do
putWord8 1
let list = map BinaryYaml (V.toList arr) :: [BinaryYaml]
put list
Yaml.String s -> putWord8 2 >> put s
Yaml.Number n -> putWord8 3 >> put n
Yaml.Bool b -> putWord8 4 >> put b
Yaml.Null -> putWord8 5
get = do
tag <- getWord8
case tag of
0 -> do
list <- get :: Get [(T.Text, BinaryYaml)]
return $ BinaryYaml $ Yaml.Object $
HMS.fromList $ map (second unBinaryYaml) list
1 -> do
list <- get :: Get [BinaryYaml]
return $ BinaryYaml $
Yaml.Array $ V.fromList $ map unBinaryYaml list
2 -> BinaryYaml . Yaml.String <$> get
3 -> BinaryYaml . Yaml.Number <$> get
4 -> BinaryYaml . Yaml.Bool <$> get
5 -> return $ BinaryYaml Yaml.Null
_ -> fail "Data.Binary.get: Invalid Binary Metadata"

115
src/Hakyll/Core/Provider/Metadata.hs
View file

@ -1,33 +1,32 @@
--------------------------------------------------------------------------------
-- | Internal module to parse metadata
{-# LANGUAGE BangPatterns #-}
module Hakyll.Core.Provider.Metadata
( loadMetadata
, metadata
, page
-- This parser can be reused in some places
, metadataKey
, parsePage
) where
--------------------------------------------------------------------------------
import Control.Applicative
import Control.Arrow (second)
import Control.Monad (guard)
import qualified Data.ByteString.Char8 as BC
import qualified Data.HashMap.Strict as HMS
import Data.List (intercalate)
import Data.List.Extended (breakWhen)
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 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 Hakyll.Core.Util.Parser
import Hakyll.Core.Util.String
import System.IO as IO
--------------------------------------------------------------------------------
@ -36,13 +35,13 @@ loadMetadata p identifier = do
hasHeader <- probablyHasMetadataHeader fp
(md, body) <- if hasHeader
then second Just <$> loadMetadataHeader fp
else return (M.empty, Nothing)
else return (mempty, Nothing)
emd <- case mi of
Nothing -> return M.empty
Nothing -> return mempty
Just mi' -> loadMetadataFile $ resourceFilePath p mi'
return (M.union md emd, body)
return (md <> emd, body)
where
normal = setVersion Nothing identifier
fp = resourceFilePath p identifier
@ -52,19 +51,15 @@ loadMetadata p identifier = do
--------------------------------------------------------------------------------
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)
fileContent <- readFile fp
either fail return (parsePage fileContent)
--------------------------------------------------------------------------------
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
errOrMeta <- Yaml.decodeFileEither fp
either (fail . show) return errOrMeta
--------------------------------------------------------------------------------
@ -83,53 +78,41 @@ probablyHasMetadataHeader fp = do
--------------------------------------------------------------------------------
-- | 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 <- metadataKey
_ <- P.char ':'
P.skipMany1 inlineSpace <?> "space followed by metadata for: " ++ key
value <- P.manyTill P.anyChar newline
trailing' <- P.many trailing
return (key, trim $ intercalate " " $ value : trailing')
-- | Parse the page metadata and body.
splitMetadata :: String -> (Maybe String, String)
splitMetadata str0 = fromMaybe (Nothing, str0) $ do
guard $ leading >= 3
let !(!meta, !content0) = breakWhen isTrailing (drop leading str0)
guard $ not $ null content0
let !content1 = drop (leading + 1) content0
!content2 = dropWhile isNewline $ dropWhile isInlineSpace content1
return (Just meta, content2)
where
trailing = P.many1 inlineSpace *> P.manyTill P.anyChar newline
-- 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 == ' '
--------------------------------------------------------------------------------
-- | Parse a metadata block
metadata :: Parser [(String, String)]
metadata = P.many metadataField
parseMetadata :: String -> Either String Metadata
parseMetadata = Yaml.decodeEither . T.encodeUtf8 . T.pack
--------------------------------------------------------------------------------
-- | 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)
parsePage :: String -> Either String (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

9
src/Hakyll/Core/Provider/MetadataCache.hs
View file

@ -8,9 +8,6 @@ module Hakyll.Core.Provider.MetadataCache
--------------------------------------------------------------------------------
import Control.Monad (unless)
import qualified Data.Map as M
--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
@ -21,11 +18,11 @@ import qualified Hakyll.Core.Store as Store
--------------------------------------------------------------------------------
resourceMetadata :: Provider -> Identifier -> IO Metadata
resourceMetadata p r
| not (resourceExists p r) = return M.empty
| not (resourceExists p r) = return mempty
| otherwise = do
-- TODO keep time in md cache
load p r
Store.Found md <- Store.get (providerStore p)
Store.Found (BinaryMetadata md) <- Store.get (providerStore p)
[name, toFilePath r, "metadata"]
return md
@ -52,7 +49,7 @@ load p r = do
mmof <- Store.isMember store mdk
unless mmof $ do
(md, body) <- loadMetadata p r
Store.set store mdk md
Store.set store mdk (BinaryMetadata md)
Store.set store bk body
where
store = providerStore p

1
src/Hakyll/Core/Routes.hs
View file

@ -42,7 +42,6 @@ module Hakyll.Core.Routes
--------------------------------------------------------------------------------
import Data.Monoid (Monoid, mappend, mempty)
import System.FilePath (replaceExtension)

2
src/Hakyll/Core/Runtime.hs
View file

@ -5,7 +5,6 @@ module Hakyll.Core.Runtime
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Monad (unless)
import Control.Monad.Error (ErrorT, runErrorT, throwError)
import Control.Monad.Reader (ask)
@ -15,7 +14,6 @@ import Control.Monad.Trans (liftIO)
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid (mempty)
import Data.Set (Set)
import qualified Data.Set as S
import System.Exit (ExitCode (..))

11
src/Hakyll/Web/Pandoc/Biblio.hs
View file

@ -23,22 +23,19 @@ module Hakyll.Web.Pandoc.Biblio
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Monad (replicateM, liftM)
import Control.Monad (liftM, replicateM)
import Data.Binary (Binary (..))
import Data.Default (def)
import Data.Typeable (Typeable)
import qualified Text.CSL as CSL
import Text.CSL.Pandoc (processCites)
import Text.Pandoc (Pandoc, ReaderOptions (..))
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Writable
import Hakyll.Web.Pandoc
import Hakyll.Web.Pandoc.Binary ()
import qualified Text.CSL as CSL
import Text.CSL.Pandoc (processCites)
import Text.Pandoc (Pandoc, ReaderOptions (..))
--------------------------------------------------------------------------------

12
src/Hakyll/Web/Tags.hs
View file

@ -63,13 +63,12 @@ module Hakyll.Web.Tags
--------------------------------------------------------------------------------
import Control.Arrow ((&&&))
import Control.Monad (foldM, forM, forM_)
import Control.Monad (foldM, forM, forM_, mplus)
import Data.Char (toLower)
import Data.List (intercalate, intersperse,
sortBy)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (mconcat)
import Data.Ord (comparing)
import qualified Data.Set as S
import System.FilePath (takeBaseName, takeDirectory)
@ -88,8 +87,8 @@ import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Core.Rules
import Hakyll.Core.Util.String
import Hakyll.Web.Template.Context
import Hakyll.Web.Html
import Hakyll.Web.Template.Context
--------------------------------------------------------------------------------
@ -103,11 +102,14 @@ data Tags = Tags
--------------------------------------------------------------------------------
-- | Obtain tags from a page in the default way: parse them from the @tags@
-- metadata field.
-- metadata field. This can either be a list or a comma-separated string.
getTags :: MonadMetadata m => Identifier -> m [String]
getTags identifier = do
metadata <- getMetadata identifier
return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
return $ fromMaybe [] $
(lookupStringList "tags" metadata) `mplus`
(map trim . splitAll "," <$> lookupString "tags" metadata)
--------------------------------------------------------------------------------
-- | Obtain categories from a page.

10
src/Hakyll/Web/Template/Context.hs
View file

@ -31,18 +31,13 @@ module Hakyll.Web.Template.Context
--------------------------------------------------------------------------------
import Control.Applicative (Alternative (..), pure, (<$>))
import Control.Applicative (Alternative (..))
import Control.Monad (msum)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Monoid (Monoid (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime)
import qualified Data.Time.Format as TF
import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
import System.FilePath (splitDirectories, takeBaseName)
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Identifier
@ -51,6 +46,7 @@ import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Hakyll.Core.Util.String (needlePrefix, splitAll)
import Hakyll.Web.Html
import System.FilePath (splitDirectories, takeBaseName)
--------------------------------------------------------------------------------
@ -274,7 +270,7 @@ getItemUTC :: MonadMetadata m
-> m UTCTime -- ^ Parsed UTCTime
getItemUTC locale id' = do
metadata <- getMetadata id'
let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
let tryField k fmt = lookupString k metadata >>= parseTime' fmt
paths = splitDirectories $ toFilePath id'
maybe empty' return $ msum $

12
stack.yaml Normal file
View file

@ -0,0 +1,12 @@
resolver: lts-5.11
extra-deps: []
extra-package-dbs: []
flags:
hakyll:
previewServer: True
watchServer: True
checkExternal: True
packages:
- '.'

27
tests/Hakyll/Core/Provider/Metadata/Tests.hs
View file

@ -5,14 +5,13 @@ module Hakyll.Core.Provider.Metadata.Tests
--------------------------------------------------------------------------------
import qualified Data.HashMap.Strict as HMS
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Metadata
import Test.Framework (Test, testGroup)
import Test.HUnit (Assertion, (@=?))
import Text.Parsec as P
import Text.Parsec.String (Parser)
--------------------------------------------------------------------------------
import Hakyll.Core.Provider.Metadata
import TestSuite.Util
@ -22,9 +21,11 @@ tests = testGroup "Hakyll.Core.Provider.Metadata.Tests" $
fromAssertions "page" [testPage01, testPage02]
--------------------------------------------------------------------------------
testPage01 :: Assertion
testPage01 = testParse page ([("foo", "bar")], "qux\n")
testPage01 =
Right (meta [("foo", "bar")], "qux\n") @=? parsePage
"---\n\
\foo: bar\n\
\---\n\
@ -33,21 +34,21 @@ testPage01 = testParse page ([("foo", "bar")], "qux\n")
--------------------------------------------------------------------------------
testPage02 :: Assertion
testPage02 = testParse page
([("description", descr)], "Hello I am dog\n")
testPage02 =
Right (meta [("description", descr)], "Hello I am dog\n") @=?
parsePage
"---\n\
\description: A long description that would look better if it\n\
\ spanned multiple lines and was indented\n\
\---\n\
\Hello I am dog\n"
where
descr :: String
descr =
"A long description that would look better if it \
\spanned multiple lines and was indented"
--------------------------------------------------------------------------------
testParse :: (Eq a, Show a) => Parser a -> a -> String -> Assertion
testParse parser expected input = case P.parse parser "<inline>" input of
Left err -> error $ show err
Right x -> expected @=? x
meta :: Yaml.ToJSON a => [(String, a)] -> Metadata
meta pairs = HMS.fromList [(T.pack k, Yaml.toJSON v) | (k, v) <- pairs]

13
tests/Hakyll/Core/Provider/Tests.hs
View file

@ -6,14 +6,11 @@ module Hakyll.Core.Provider.Tests
--------------------------------------------------------------------------------
import qualified Data.Map as M
import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assert, (@=?))
--------------------------------------------------------------------------------
import Hakyll.Core.Provider
import TestSuite.Util
@ -32,9 +29,9 @@ case01 = do
assert $ resourceExists provider "example.md"
metadata <- resourceMetadata provider "example.md"
Just "An example" @=? M.lookup "title" metadata
Just "External data" @=? M.lookup "external" metadata
Just "An example" @=? lookupString "title" metadata
Just "External data" @=? lookupString "external" metadata
doesntExist <- resourceMetadata provider "doesntexist.md"
M.empty @=? doesntExist
mempty @=? doesntExist
cleanTestEnv

12
tests/Hakyll/Core/Routes/Tests.hs
View file

@ -6,15 +6,13 @@ module Hakyll.Core.Routes.Tests
--------------------------------------------------------------------------------
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Routes
import System.FilePath ((</>))
import Test.Framework (Test, testGroup)
import Test.HUnit (Assertion, (@=?))
--------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Routes
import TestSuite.Util
@ -37,7 +35,7 @@ tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes"
"tags/rss/bar"
, testRoutes "food/example.md" (metadataRoute $ \md -> customRoute $ \id' ->
M.findWithDefault "?" "subblog" md </> toFilePath id')
fromMaybe "?" (lookupString "subblog" md) </> toFilePath id')
"example.md"
]

13
tests/Hakyll/Core/Rules/Tests.hs
View file

@ -8,22 +8,19 @@ module Hakyll.Core.Rules.Tests
--------------------------------------------------------------------------------
import Data.IORef (IORef, newIORef, readIORef,
writeIORef)
import qualified Data.Map as M
import qualified Data.Set as S
import System.FilePath ((</>))
import Test.Framework (Test, testGroup)
import Test.HUnit (Assertion, assert, (@=?))
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.File
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.Metadata
import Hakyll.Core.Routes
import Hakyll.Core.Rules
import Hakyll.Core.Rules.Internal
import Hakyll.Web.Pandoc
import System.FilePath ((</>))
import Test.Framework (Test, testGroup)
import Test.HUnit (Assertion, assert, (@=?))
import TestSuite.Util
@ -89,7 +86,7 @@ rules01 ioref = do
compile getResourceString
version "metadataMatch" $
matchMetadata "*.md" (\md -> M.lookup "subblog" md == Just "food") $ do
matchMetadata "*.md" (\md -> lookupString "subblog" md == Just "food") $ do
route $ customRoute $ \id' -> "food" </> toFilePath id'
compile getResourceString