{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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
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
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"
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
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
]