@@ -0,0 +1,481 @@
1+-- | This module provides 'Context's which are used to expand expressions in
2+-- templates and allow for arbitrary customisation.
3+--
4+-- 'Template's define a small expression DSL which consists of strings,
5+-- identifiers and function application. There is no type system, every value is
6+-- a string and on the top level they get substituted verbatim into the page.
7+--
8+-- For example, you can build a context that contains
9+--
10+-- > … <> functionField "concat" (const . concat) <> …
11+--
12+-- which will allow you to use the @concat@ identifier as a function that takes
13+-- arbitrarily many stings and concatenates them to a new string:
14+--
15+-- > $partial(concat("templates/categories/", category))$
16+--
17+-- This will evaluate the @category@ field in the context, then prepend he path,
18+-- and include the referenced file as a template.
19+
20+
21+--------------------------------------------------------------------------------
22+{-# LANGUAGE CPP #-}
23+{-# LANGUAGE ExistentialQuantification #-}
24+{-# LANGUAGE RankNTypes #-}
25+module Hakyll.Web.Template.Context
26+ ( ContextField (..)
27+ , Context (..)
28+ , field
29+ , boolField
30+ , constField
31+ , listField
32+ , listFieldWith
33+ , functionField
34+ , mapContext
35+
36+ , defaultContext
37+ , bodyField
38+ , metadataField
39+ , urlField
40+ , pathField
41+ , titleField
42+ , snippetField
43+ , dateField
44+ , dateFieldWith
45+ , getItemUTC
46+ , getItemModificationTime
47+ , modificationTimeField
48+ , modificationTimeFieldWith
49+ , teaserField
50+ , teaserFieldWithSeparator
51+ , missingField
52+ , bindItem
53+ ) where
54+
55+
56+--------------------------------------------------------------------------------
57+import Control.Applicative (Alternative (..))
58+import Control.Monad (msum)
59+import Data.List (intercalate, tails)
60+#if MIN_VERSION_base(4,9,0)
61+import Data.Semigroup (Semigroup (..))
62+#endif
63+import Data.Time.Clock (UTCTime (..))
64+import Data.Time.Format (formatTime)
65+import qualified Data.Time.Format as TF
66+import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
67+import Hakyll.Core.Compiler
68+import Hakyll.Core.Compiler.Internal
69+import Hakyll.Core.Identifier
70+import Hakyll.Core.Item
71+import Hakyll.Core.Metadata
72+import Hakyll.Core.Provider
73+import Hakyll.Core.Util.String (needlePrefix, splitAll)
74+import Hakyll.Web.Html
75+import Prelude hiding (id)
76+import System.FilePath (dropExtension, splitDirectories,
77+ takeBaseName)
78+
79+
80+--------------------------------------------------------------------------------
81+-- | Mostly for internal usage
82+data ContextField
83+ = EmptyField
84+ | StringField String
85+ | forall a. ListField (Context a) [Item a]
86+
87+
88+--------------------------------------------------------------------------------
89+-- | The 'Context' monoid. Please note that the order in which you
90+-- compose the items is important. For example in
91+--
92+-- > field "A" f1 <> field "A" f2
93+--
94+-- the first context will overwrite the second. This is especially
95+-- important when something is being composed with
96+-- 'metadataField' (or 'defaultContext'). If you want your context to be
97+-- overwritten by the metadata fields, compose it from the right:
98+--
99+-- @
100+-- 'metadataField' \<\> field \"date\" fDate
101+-- @
102+--
103+newtype Context a = Context
104+ { unContext :: String -> [String] -> Item a -> Compiler ContextField
105+ }
106+
107+
108+--------------------------------------------------------------------------------
109+-- | Tries to find a key in the left context,
110+-- or when that fails in the right context.
111+#if MIN_VERSION_base(4,9,0)
112+instance Semigroup (Context a) where
113+ (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
114+
115+instance Monoid (Context a) where
116+ mempty = missingField
117+ mappend = (<>)
118+#else
119+instance Monoid (Context a) where
120+ mempty = missingField
121+ mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
122+#endif
123+
124+
125+--------------------------------------------------------------------------------
126+field' :: String -> (Item a -> Compiler ContextField) -> Context a
127+field' key value = Context $ \k _ i ->
128+ if k == key
129+ then value i
130+ else noResult $ "Tried field " ++ key
131+
132+
133+--------------------------------------------------------------------------------
134+-- | Constructs a new field for a 'Context'.
135+-- If the key matches, the compiler is run and its result is substituted in the
136+-- template.
137+--
138+-- If the compiler fails, the field will be considered non-existent
139+-- in an @$if()$@ macro or ultimately break the template application
140+-- (unless the key is found in another context when using '<>').
141+-- Use 'empty' or 'noResult' for intentional failures of fields used in
142+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'.
143+field
144+ :: String -- ^ Key
145+ -> (Item a -> Compiler String) -- ^ Function that constructs a value based
146+ -- on the item (e.g. accessing metadata)
147+ -> Context a
148+field key value = field' key (fmap StringField . value)
149+
150+
151+--------------------------------------------------------------------------------
152+-- | Creates a 'field' to use with the @$if()$@ template macro.
153+-- Attempting to substitute the field into the template will cause an error.
154+boolField
155+ :: String
156+ -> (Item a -> Bool)
157+ -> Context a
158+boolField name f = field' name (\i -> if f i
159+ then return EmptyField
160+ else noResult $ "Field " ++ name ++ " is false")
161+
162+
163+--------------------------------------------------------------------------------
164+-- | Creates a 'field' that does not depend on the 'Item' but always yields
165+-- the same string
166+constField :: String -- ^ Key
167+ -> String -- ^ Value
168+ -> Context a
169+constField key = field key . const . return
170+
171+
172+--------------------------------------------------------------------------------
173+-- | Creates a list field to be consumed by a @$for(…)$@ expression.
174+-- The compiler returns multiple items which are rendered in the loop body
175+-- with the supplied context.
176+listField :: String -> Context a -> Compiler [Item a] -> Context b
177+listField key c xs = listFieldWith key c (const xs)
178+
179+
180+--------------------------------------------------------------------------------
181+-- | Produces a new 'Context' which has list field 'key'. All fields from
182+-- 'c' are also accessible from the produced context.
183+-- Be careful when doing @listFieldWith k ca f <> cb@ as any fields in @ca@
184+-- will override fields in @cb@ with the same name.
185+-- Creates a list field like 'listField', but supplies the current page
186+-- to the compiler.
187+listFieldWith
188+ :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
189+listFieldWith key c f = field' key $ fmap (ListField c) . f
190+
191+
192+--------------------------------------------------------------------------------
193+-- | Creates a variadic function field.
194+--
195+-- The function will be called with the dynamically evaluated string arguments
196+-- from the template as well as the page that is currently rendered.
197+functionField :: String -- ^ Key
198+ -> ([String] -> Item a -> Compiler String) -- ^ Function
199+ -> Context a
200+functionField name value = Context $ \k args i ->
201+ if k == name
202+ then StringField <$> value args i
203+ else noResult $ "Tried function field " ++ name
204+
205+
206+--------------------------------------------------------------------------------
207+-- | Transform the respective string results of all fields in a context.
208+-- For example,
209+--
210+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")
211+--
212+-- is equivalent to
213+--
214+-- > constField "x" "ac" <> constField "y" "bc"
215+--
216+mapContext :: (String -> String) -> Context a -> Context a
217+mapContext f (Context c) = Context $ \k a i -> do
218+ fld <- c k a i
219+ case fld of
220+ EmptyField -> wrongType "boolField"
221+ StringField str -> return $ StringField (f str)
222+ _ -> wrongType "ListField"
223+ where
224+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++
225+ "can't map over a " ++ typ ++ "!"
226+
227+--------------------------------------------------------------------------------
228+-- | A context that allows snippet inclusion. In processed file, use as:
229+--
230+-- > ...
231+-- > $snippet("path/to/snippet/")$
232+-- > ...
233+--
234+-- The contents of the included file will not be interpolated like @partial@
235+-- does it.
236+--
237+snippetField :: Context String
238+snippetField = functionField "snippet" f
239+ where
240+ f [contentsPath] _ = loadBody (fromFilePath contentsPath)
241+ f [] _ = fail "No argument to function 'snippet()'"
242+ f _ _ = fail "Too many arguments to function 'snippet()'"
243+
244+--------------------------------------------------------------------------------
245+-- | A context that contains (in that order)
246+--
247+-- 1. A @$body$@ field
248+--
249+-- 2. Metadata fields
250+--
251+-- 3. A @$url$@ 'urlField'
252+--
253+-- 4. A @$path$@ 'pathField'
254+--
255+-- 5. A @$title$@ 'titleField'
256+defaultContext :: Context String
257+defaultContext =
258+ bodyField "body" `mappend`
259+ metadataField `mappend`
260+ urlField "url" `mappend`
261+ pathField "path" `mappend`
262+ titleField "title"
263+
264+
265+--------------------------------------------------------------------------------
266+teaserSeparator :: String
267+teaserSeparator = "<!--more-->"
268+
269+
270+--------------------------------------------------------------------------------
271+-- | Constructs a 'field' that contains the body of the item.
272+bodyField :: String -> Context String
273+bodyField key = field key $ return . itemBody
274+
275+
276+--------------------------------------------------------------------------------
277+-- | Map any field to its metadata value, if present
278+metadataField :: Context a
279+metadataField = Context $ \k _ i -> do
280+ let id = itemIdentifier i
281+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " ++
282+ "of item " ++ show id
283+ value <- getMetadataField id k
284+ maybe empty' (return . StringField) value
285+
286+
287+--------------------------------------------------------------------------------
288+-- | Absolute url to the resulting item
289+urlField :: String -> Context a
290+urlField key = field key $ \i -> do
291+ let id = itemIdentifier i
292+ empty' = fail $ "No route url found for item " ++ show id
293+ fmap (maybe empty' toUrl) $ getRoute id
294+
295+
296+--------------------------------------------------------------------------------
297+-- | Filepath of the underlying file of the item
298+pathField :: String -> Context a
299+pathField key = field key $ return . toFilePath . itemIdentifier
300+
301+
302+--------------------------------------------------------------------------------
303+-- | This title 'field' takes the basename of the underlying file by default
304+titleField :: String -> Context a
305+titleField = mapContext takeBaseName . pathField
306+
307+
308+--------------------------------------------------------------------------------
309+-- | When the metadata has a field called @published@ in one of the
310+-- following formats then this function can render the date.
311+--
312+-- * @Mon, 06 Sep 2010 00:01:00 +0000@
313+--
314+-- * @Mon, 06 Sep 2010 00:01:00 UTC@
315+--
316+-- * @Mon, 06 Sep 2010 00:01:00@
317+--
318+-- * @2010-09-06T00:01:00+0000@
319+--
320+-- * @2010-09-06T00:01:00Z@
321+--
322+-- * @2010-09-06T00:01:00@
323+--
324+-- * @2010-09-06 00:01:00+0000@
325+--
326+-- * @2010-09-06 00:01:00@
327+--
328+-- * @September 06, 2010 00:01 AM@
329+--
330+-- Following date-only formats are supported too (@00:00:00@ for time is
331+-- assumed)
332+--
333+-- * @2010-09-06@
334+--
335+-- * @September 06, 2010@
336+--
337+-- Alternatively, when the metadata has a field called @path@ in a
338+-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
339+-- and no @published@ metadata field set, this function can render
340+-- the date. This pattern matches the file name or directory names
341+-- that begins with @yyyy-mm-dd@ . For example:
342+-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
343+-- In case of multiple matches, the rightmost one is used.
344+--
345+-- As another alternative, if none of the above matches, and the file has a
346+-- path which contains nested directories specifying a date, then that date
347+-- will be used. In other words, if the path is of the form
348+-- @**//yyyy//mm//dd//**//main.extension@ .
349+-- As above, in case of multiple matches, the rightmost one is used.
350+
351+dateField :: String -- ^ Key in which the rendered date should be placed
352+ -> String -- ^ Format to use on the date
353+ -> Context a -- ^ Resulting context
354+dateField = dateFieldWith defaultTimeLocale
355+
356+
357+--------------------------------------------------------------------------------
358+-- | This is an extended version of 'dateField' that allows you to
359+-- specify a time locale that is used for outputting the date. For more
360+-- details, see 'dateField' and 'formatTime'.
361+dateFieldWith :: TimeLocale -- ^ Output time locale
362+ -> String -- ^ Destination key
363+ -> String -- ^ Format to use on the date
364+ -> Context a -- ^ Resulting context
365+dateFieldWith locale key format = field key $ \i -> do
366+ time <- getItemUTC locale $ itemIdentifier i
367+ return $ formatTime locale format time
368+
369+
370+--------------------------------------------------------------------------------
371+-- | Parser to try to extract and parse the time from the @published@
372+-- field or from the filename. See 'dateField' for more information.
373+-- Exported for user convenience.
374+getItemUTC :: MonadMetadata m
375+ => TimeLocale -- ^ Output time locale
376+ -> Identifier -- ^ Input page
377+ -> m UTCTime -- ^ Parsed UTCTime
378+getItemUTC locale id' = do
379+ metadata <- getMetadata id'
380+ let tryField k fmt = lookupString k metadata >>= parseTime' fmt
381+ paths = splitDirectories $ (dropExtension . toFilePath) id'
382+
383+ maybe empty' return $ msum $
384+ [tryField "published" fmt | fmt <- formats] ++
385+ [tryField "date" fmt | fmt <- formats] ++
386+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths] ++
387+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ fnCand | fnCand <- map (take 3) $ reverse . tails $ paths]
388+ where
389+ empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
390+ "could not parse time for " ++ show id'
391+ parseTime' = parseTimeM True locale
392+ formats =
393+ [ "%a, %d %b %Y %H:%M:%S %Z"
394+ , "%Y-%m-%dT%H:%M:%S%Z"
395+ , "%Y-%m-%d %H:%M:%S%Z"
396+ , "%Y-%m-%d"
397+ , "%B %e, %Y %l:%M %p"
398+ , "%B %e, %Y"
399+ , "%b %d, %Y"
400+ ]
401+
402+
403+--------------------------------------------------------------------------------
404+-- | Get the time on which the actual file was last modified. This only works if
405+-- there actually is an underlying file, of couse.
406+getItemModificationTime
407+ :: Identifier
408+ -> Compiler UTCTime
409+getItemModificationTime identifier = do
410+ provider <- compilerProvider <$> compilerAsk
411+ return $ resourceModificationTime provider identifier
412+
413+
414+--------------------------------------------------------------------------------
415+-- | Creates a field with the last modification date of the underlying item.
416+modificationTimeField :: String -- ^ Key
417+ -> String -- ^ Format
418+ -> Context a -- ^ Resulting context
419+modificationTimeField = modificationTimeFieldWith defaultTimeLocale
420+
421+
422+--------------------------------------------------------------------------------
423+-- | Creates a field with the last modification date of the underlying item
424+-- in a custom localisation format (see 'formatTime').
425+modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
426+ -> String -- ^ Key
427+ -> String -- ^ Format
428+ -> Context a -- ^ Resulting context
429+modificationTimeFieldWith locale key fmt = field key $ \i -> do
430+ mtime <- getItemModificationTime $ itemIdentifier i
431+ return $ formatTime locale fmt mtime
432+
433+
434+--------------------------------------------------------------------------------
435+-- | A context with "teaser" key which contain a teaser of the item.
436+-- The item is loaded from the given snapshot (which should be saved
437+-- in the user code before any templates are applied).
438+teaserField :: String -- ^ Key to use
439+ -> Snapshot -- ^ Snapshot to load
440+ -> Context String -- ^ Resulting context
441+teaserField = teaserFieldWithSeparator teaserSeparator
442+
443+
444+--------------------------------------------------------------------------------
445+-- | A context with "teaser" key which contain a teaser of the item, defined as
446+-- the snapshot content before the teaser separator. The item is loaded from the
447+-- given snapshot (which should be saved in the user code before any templates
448+-- are applied).
449+teaserFieldWithSeparator :: String -- ^ Separator to use
450+ -> String -- ^ Key to use
451+ -> Snapshot -- ^ Snapshot to load
452+ -> Context String -- ^ Resulting context
453+teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
454+ body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
455+ case needlePrefix separator body of
456+ Nothing -> fail $
457+ "Hakyll.Web.Template.Context: no teaser defined for " ++
458+ show (itemIdentifier item)
459+ Just t -> return t
460+
461+
462+--------------------------------------------------------------------------------
463+-- | Constantly reports any field as missing. Mostly for internal usage,
464+-- it is the last choice in every context used in a template application.
465+missingField :: Context a
466+missingField = Context $ \k _ _ -> noResult $
467+ "Missing field '" ++ k ++ "' in context"
468+
469+parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
470+#if MIN_VERSION_time(1,5,0)
471+parseTimeM = TF.parseTimeM
472+#else
473+parseTimeM _ = TF.parseTime
474+#endif
475+
476+--------------------------------------------------------------------------------
477+
478+-- | Binds an 'Item' to a given 'Context', allowing it to be combined with any
479+-- other 'Context' of any type.
480+bindItem :: Context a -> Item a -> forall b. Context b
481+bindItem (Context ctx) ia = Context $ \k args _ -> ctx k args ia