{-# LANGUAGE OverloadedStrings #-}

{- |

JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary
for articles.  Google applications and other search engines use
these data to improve search results and links.

This implementation supports the following fields:

+-------------------+----------------------------------------------------+
| @\@type@          | __Hardcoded__ value @\"Article"@.                  |
+-------------------+----------------------------------------------------+
| @headline@        | __Required__ taken from context field @title@.     |
+-------------------+----------------------------------------------------+
| @datePublished@   | __Required__ date of publication, via 'dateField'. |
+-------------------+----------------------------------------------------+

To use, add a 'jsonldField' to your template context:

@
let
  context = 'defaultContext' <> …
  postContext =
    context
    <> 'jsonldField' "jsonld" context
@

And update the template:

@
\<head>
  \<title>$title$\</title>
  \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />
  $if(jsonld)$$jsonld("embed")$$endif$
\</head>
@

The @"embed"@ argument generates a @\<script …>@ tag to be directly
included in page HTML.  To get the raw JSON string, use @"raw"@
instead.

-}
module Hakyll.Web.Meta.JSONLD
  ( jsonldField
  ) where

import Data.Aeson ((.=), pairs)
import Data.Aeson.Encoding (encodingToLazyByteString)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT

import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Item
import Hakyll.Web.Template
import Hakyll.Web.Template.Context

runContext :: Context String -> String -> Compiler String
runContext :: Context String -> String -> Compiler String
runContext Context String
ctx String
k = do
  Item String
i <- String -> Compiler (Item String)
forall a. a -> Compiler (Item a)
makeItem String
"dummy"
  Context String
-> String -> [String] -> Item String -> Compiler ContextField
forall a.
Context a -> String -> [String] -> Item a -> Compiler ContextField
unContext Context String
ctx String
k [] Item String
i Compiler ContextField
-> (ContextField -> Compiler String) -> Compiler String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ContextField
cf -> case ContextField
cf of
    StringField String
s -> String -> Compiler String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
    ContextField
_             -> String -> Compiler String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"Error: '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is not a StringField"

getContext :: Context String -> String -> Compiler String
getContext :: Context String -> String -> Compiler String
getContext Context String
ctx String
k = Compiler String -> Compiler (Either (CompilerErrors String) String)
forall a. Compiler a -> Compiler (Either (CompilerErrors String) a)
compilerTry (Context String -> String -> Compiler String
runContext Context String
ctx String
k) Compiler (Either (CompilerErrors String) String)
-> (Either (CompilerErrors String) String -> Compiler String)
-> Compiler String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CompilerErrors String -> Compiler String)
-> (String -> Compiler String)
-> Either (CompilerErrors String) String
-> Compiler String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerErrors String -> Compiler String
forall a. CompilerErrors String -> Compiler a
f String -> Compiler String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
  f :: CompilerErrors String -> Compiler a
f (CompilationNoResult [String]
_) = CompilerResult a -> Compiler a
forall a. CompilerResult a -> Compiler a
compilerResult (CompilerResult a -> Compiler a)
-> (String -> CompilerResult a) -> String -> Compiler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerErrors String -> CompilerResult a
forall a. CompilerErrors String -> CompilerResult a
CompilerError (CompilerErrors String -> CompilerResult a)
-> (String -> CompilerErrors String) -> String -> CompilerResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> CompilerErrors String
forall a. NonEmpty a -> CompilerErrors a
CompilationFailure (NonEmpty String -> CompilerErrors String)
-> (String -> NonEmpty String) -> String -> CompilerErrors String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Compiler a) -> String -> Compiler a
forall a b. (a -> b) -> a -> b
$
                              String
"missing required field '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
  f CompilerErrors String
err = CompilerResult a -> Compiler a
forall a. CompilerResult a -> Compiler a
compilerResult (CompilerErrors String -> CompilerResult a
forall a. CompilerErrors String -> CompilerResult a
CompilerError CompilerErrors String
err)

-- This may come in handy later
_lookupContext :: Context String -> String -> Compiler (Maybe String)
_lookupContext :: Context String -> String -> Compiler (Maybe String)
_lookupContext Context String
ctx String
k = Compiler String -> Compiler (Either (CompilerErrors String) String)
forall a. Compiler a -> Compiler (Either (CompilerErrors String) a)
compilerTry (Context String -> String -> Compiler String
runContext Context String
ctx String
k) Compiler (Either (CompilerErrors String) String)
-> (Either (CompilerErrors String) String
    -> Compiler (Maybe String))
-> Compiler (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CompilerErrors String -> Compiler (Maybe String))
-> (String -> Compiler (Maybe String))
-> Either (CompilerErrors String) String
-> Compiler (Maybe String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerErrors String -> Compiler (Maybe String)
forall a. CompilerErrors String -> Compiler (Maybe a)
f (Maybe String -> Compiler (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Compiler (Maybe String))
-> (String -> Maybe String) -> String -> Compiler (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just)
  where
  f :: CompilerErrors String -> Compiler (Maybe a)
f (CompilationNoResult [String]
_) = Maybe a -> Compiler (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  f CompilerErrors String
err = CompilerResult (Maybe a) -> Compiler (Maybe a)
forall a. CompilerResult a -> Compiler a
compilerResult (CompilerErrors String -> CompilerResult (Maybe a)
forall a. CompilerErrors String -> CompilerResult a
CompilerError CompilerErrors String
err)

-- | Render JSON-LD for an article.
-- Requires context with "title", and the item must be able to yield
-- a valid date via 'getItemUTC'
--
renderJSONLD :: Context String -> Compiler (Item String)
renderJSONLD :: Context String -> Compiler (Item String)
renderJSONLD Context String
ctx = do
  String
dateString <- Context String -> String -> Compiler String
getContext (String -> String -> Context String
forall a. String -> String -> Context a
dateField String
"" String
"%Y-%m-%dT%H:%M:%S") String
""
  String
titleString <- Context String -> String -> Compiler String
getContext Context String
ctx String
"title"

  let
    obj :: Encoding
obj = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
      Key
"@context" Key -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
"https://schema.org" :: String)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"@type" Key -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (String
"Article" :: String)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"headline" Key -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
titleString
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"datePublished" Key -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
dateString

  String -> Compiler (Item String)
forall a. a -> Compiler (Item a)
makeItem (String -> Compiler (Item String))
-> (Encoding -> String) -> Encoding -> Compiler (Item String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack (Text -> String) -> (Encoding -> Text) -> Encoding -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8 (ByteString -> Text)
-> (Encoding -> ByteString) -> Encoding -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
forall a. Encoding' a -> ByteString
encodingToLazyByteString (Encoding -> Compiler (Item String))
-> Encoding -> Compiler (Item String)
forall a b. (a -> b) -> a -> b
$ Encoding
obj

jsonldField :: String -> Context String -> Context String
jsonldField :: String -> Context String -> Context String
jsonldField String
k Context String
ctx = String
-> ([String] -> Item String -> Compiler String) -> Context String
forall a.
String -> ([String] -> Item a -> Compiler String) -> Context a
functionField String
k (\[String]
args Item String
_i -> [String] -> Compiler String
forall a. (Eq a, IsString a) => [a] -> Compiler String
go [String]
args)
  where
  -- The zero argument case cannot be a compiler error,
  -- otherwise @$if(k)$@ evaluates false.
  go :: [a] -> Compiler String
go [] = String -> Compiler String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"<!-- Whoops! Try this instead: $if(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")$$" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"(\"embed\")$$endif$ -->"
  go [a
"raw"] = Item String -> String
forall a. Item a -> a
itemBody (Item String -> String)
-> Compiler (Item String) -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context String -> Compiler (Item String)
renderJSONLD Context String
ctx
  go [a
"embed"] = do
    Template
template <- Compiler Template
jsonldTemplate
    Item String
i <- Context String -> Compiler (Item String)
renderJSONLD Context String
ctx Compiler (Item String)
-> (Item String -> Compiler (Item String))
-> Compiler (Item String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Template -> Context String -> Item String -> Compiler (Item String)
forall a. Template -> Context a -> Item a -> Compiler (Item String)
applyTemplate Template
template (String -> Context String
bodyField String
"body")
    String -> Compiler String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Item String -> String
forall a. Item a -> a
itemBody Item String
i
  go [a
_] = String -> Compiler String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"invalid argument to jsonldField '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'. use \"raw\" or \"embed\""
  go [a]
_ = String -> Compiler String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"too many arguments to jsonldField '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"

jsonldTemplate :: Compiler Template
jsonldTemplate :: Compiler Template
jsonldTemplate = do
  String -> Compiler (Item String)
forall a. a -> Compiler (Item a)
makeItem String
"<script type=\"application/ld+json\">$body$</script>"
  Compiler (Item String)
-> (Item String -> Compiler Template) -> Compiler Template
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Item String -> Compiler Template
compileTemplateItem