{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Meta tags for The Open Graph protocol: https://ogp.me/
module Rib.Extra.OpenGraph
  ( OpenGraph (..),
    OGType (..),
    Article (..),
  )
where

import Data.Time (UTCTime)
import Data.Time.Format.ISO8601 (formatShow, iso8601Format)
import Lucid
import Lucid.Base (makeAttribute)
import Relude
import qualified Text.URI as URI

-- The OpenGraph metadata
--
-- This type can be directly rendered to HTML using `toHTML`.
data OpenGraph
  = OpenGraph
      { OpenGraph -> Text
_openGraph_title :: Text,
        OpenGraph -> Maybe URI
_openGraph_url :: Maybe URI.URI,
        OpenGraph -> Maybe Text
_openGraph_author :: Maybe Text,
        OpenGraph -> Maybe Text
_openGraph_description :: Maybe Text,
        OpenGraph -> Text
_openGraph_siteName :: Text,
        OpenGraph -> Maybe OGType
_openGraph_type :: Maybe OGType,
        OpenGraph -> Maybe URI
_openGraph_image :: Maybe URI.URI
      }
  deriving (OpenGraph -> OpenGraph -> Bool
(OpenGraph -> OpenGraph -> Bool)
-> (OpenGraph -> OpenGraph -> Bool) -> Eq OpenGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpenGraph -> OpenGraph -> Bool
$c/= :: OpenGraph -> OpenGraph -> Bool
== :: OpenGraph -> OpenGraph -> Bool
$c== :: OpenGraph -> OpenGraph -> Bool
Eq, Int -> OpenGraph -> ShowS
[OpenGraph] -> ShowS
OpenGraph -> String
(Int -> OpenGraph -> ShowS)
-> (OpenGraph -> String)
-> ([OpenGraph] -> ShowS)
-> Show OpenGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpenGraph] -> ShowS
$cshowList :: [OpenGraph] -> ShowS
show :: OpenGraph -> String
$cshow :: OpenGraph -> String
showsPrec :: Int -> OpenGraph -> ShowS
$cshowsPrec :: Int -> OpenGraph -> ShowS
Show)

instance ToHtml OpenGraph where
  toHtmlRaw :: OpenGraph -> HtmlT m ()
toHtmlRaw = OpenGraph -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml
  toHtml :: OpenGraph -> HtmlT m ()
toHtml OpenGraph {..} = do
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
meta' "author" (Text -> HtmlT m ()) -> Maybe Text -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe Text
_openGraph_author
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
meta' "description" (Text -> HtmlT m ()) -> Maybe Text -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe Text
_openGraph_description
    Text -> (Text -> HtmlT m ()) -> URI -> HtmlT m ()
forall p. Text -> (Text -> p) -> URI -> p
requireAbsolute "OGP URL" (\uri :: Text
uri -> [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_ [Text -> Attribute
rel_ "canonical", Text -> Attribute
href_ Text
uri]) (URI -> HtmlT m ()) -> Maybe URI -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe URI
_openGraph_url
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "title" Text
_openGraph_title
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "site_name" Text
_openGraph_siteName
    OGType -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (OGType -> HtmlT m ()) -> Maybe OGType -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe OGType
_openGraph_type
    Text -> (Text -> HtmlT m ()) -> URI -> HtmlT m ()
forall p. Text -> (Text -> p) -> URI -> p
requireAbsolute "OGP image URL" (Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "image") (URI -> HtmlT m ()) -> Maybe URI -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe URI
_openGraph_image
    where
      meta' :: Text -> Text -> HtmlT m ()
meta' k :: Text
k v :: Text
v = [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
name_ Text
k, Text -> Attribute
content_ Text
v]
      requireAbsolute :: Text -> (Text -> p) -> URI -> p
requireAbsolute description :: Text
description f :: Text -> p
f uri :: URI
uri =
        if Maybe (RText 'Scheme) -> Bool
forall a. Maybe a -> Bool
isJust (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri)
          then Text -> p
f (Text -> p) -> Text -> p
forall a b. (a -> b) -> a -> b
$ URI -> Text
URI.render URI
uri
          else Text -> p
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> p) -> Text -> p
forall a b. (a -> b) -> a -> b
$ Text
description Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " must be absolute. this URI is not: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URI -> Text
URI.render URI
uri

-- TODO: Remaining ADT values & sub-fields
data OGType
  = OGType_Article Article
  | OGType_Website
  deriving (OGType -> OGType -> Bool
(OGType -> OGType -> Bool)
-> (OGType -> OGType -> Bool) -> Eq OGType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OGType -> OGType -> Bool
$c/= :: OGType -> OGType -> Bool
== :: OGType -> OGType -> Bool
$c== :: OGType -> OGType -> Bool
Eq, Int -> OGType -> ShowS
[OGType] -> ShowS
OGType -> String
(Int -> OGType -> ShowS)
-> (OGType -> String) -> ([OGType] -> ShowS) -> Show OGType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OGType] -> ShowS
$cshowList :: [OGType] -> ShowS
show :: OGType -> String
$cshow :: OGType -> String
showsPrec :: Int -> OGType -> ShowS
$cshowsPrec :: Int -> OGType -> ShowS
Show)

instance ToHtml OGType where
  toHtmlRaw :: OGType -> HtmlT m ()
toHtmlRaw = OGType -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml
  toHtml :: OGType -> HtmlT m ()
toHtml = \case
    OGType_Article article :: Article
article -> do
      Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "type" "article"
      Article -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Article
article
    OGType_Website -> do
      Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "type" "website"

-- TODO: _article_profile :: [Profile]
data Article
  = Article
      { Article -> Maybe Text
_article_section :: Maybe Text,
        Article -> Maybe UTCTime
_article_modifiedTime :: Maybe UTCTime,
        Article -> Maybe UTCTime
_article_publishedTime :: Maybe UTCTime,
        Article -> Maybe UTCTime
_article_expirationTime :: Maybe UTCTime,
        Article -> [Text]
_article_tag :: [Text]
      }
  deriving (Article -> Article -> Bool
(Article -> Article -> Bool)
-> (Article -> Article -> Bool) -> Eq Article
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Article -> Article -> Bool
$c/= :: Article -> Article -> Bool
== :: Article -> Article -> Bool
$c== :: Article -> Article -> Bool
Eq, Int -> Article -> ShowS
[Article] -> ShowS
Article -> String
(Int -> Article -> ShowS)
-> (Article -> String) -> ([Article] -> ShowS) -> Show Article
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Article] -> ShowS
$cshowList :: [Article] -> ShowS
show :: Article -> String
$cshow :: Article -> String
showsPrec :: Int -> Article -> ShowS
$cshowsPrec :: Int -> Article -> ShowS
Show)

instance ToHtml Article where
  toHtmlRaw :: Article -> HtmlT m ()
toHtmlRaw = Article -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml
  toHtml :: Article -> HtmlT m ()
toHtml Article {..} = do
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "article:section" (Text -> HtmlT m ()) -> Maybe Text -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe Text
_article_section
    Text -> UTCTime -> HtmlT m ()
forall (m :: * -> *) t.
(Applicative m, ISO8601 t) =>
Text -> t -> HtmlT m ()
metaOgTime "article:modified_time" (UTCTime -> HtmlT m ()) -> Maybe UTCTime -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe UTCTime
_article_modifiedTime
    Text -> UTCTime -> HtmlT m ()
forall (m :: * -> *) t.
(Applicative m, ISO8601 t) =>
Text -> t -> HtmlT m ()
metaOgTime "article:published_time" (UTCTime -> HtmlT m ()) -> Maybe UTCTime -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe UTCTime
_article_publishedTime
    Text -> UTCTime -> HtmlT m ()
forall (m :: * -> *) t.
(Applicative m, ISO8601 t) =>
Text -> t -> HtmlT m ()
metaOgTime "article:expiration_time" (UTCTime -> HtmlT m ()) -> Maybe UTCTime -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe UTCTime
_article_expirationTime
    Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg "article:tag" (Text -> HtmlT m ()) -> [Text] -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Text]
_article_tag
    where
      metaOgTime :: Text -> t -> HtmlT m ()
metaOgTime k :: Text
k t :: t
t =
        Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
metaOg Text
k (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Format t -> t -> String
forall t. Format t -> t -> String
formatShow Format t
forall t. ISO8601 t => Format t
iso8601Format t
t

-- Open graph meta element
metaOg :: Applicative m => Text -> Text -> HtmlT m ()
metaOg :: Text -> Text -> HtmlT m ()
metaOg k :: Text
k v :: Text
v =
  [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_
    [ Text -> Text -> Attribute
makeAttribute "property" (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ "og:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k,
      Text -> Attribute
content_ Text
v
    ]