79 lines
2.3 KiB
Haskell
79 lines
2.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM.Card (
|
|
Card(..)
|
|
, HasCard(..)
|
|
, make
|
|
) where
|
|
|
|
import qualified Article (Article(..))
|
|
import ArticlesList (ArticlesList(..), pageTitle)
|
|
import Blog (Blog(..), Skin(..))
|
|
import qualified Blog (get)
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.Reader (MonadReader)
|
|
import qualified Data.Map as Map (lookup)
|
|
import Data.Text (Text, pack)
|
|
import Lucid (HtmlT, content_, meta_)
|
|
import Lucid.Base (makeAttribute)
|
|
import Pretty ((.$))
|
|
|
|
data Card = Card {
|
|
cardType :: Text
|
|
, description :: Text
|
|
, image :: Maybe String
|
|
, title :: String
|
|
, urlPath :: String
|
|
}
|
|
|
|
class HasCard a where
|
|
getCard :: MonadReader Blog m => a -> m Card
|
|
|
|
og :: Applicative m => Text -> Text -> HtmlT m ()
|
|
og attribute value =
|
|
meta_ [
|
|
makeAttribute "property" $ "og:" <> attribute
|
|
, content_ value
|
|
]
|
|
|
|
make :: (HasCard a, MonadReader Blog m) => a -> String -> HtmlT m ()
|
|
make element siteURL = do
|
|
Card {cardType, description, image, title, urlPath} <- getCard element
|
|
og "url" . pack $ siteURL ++ urlPath
|
|
og "type" cardType
|
|
og "title" $ pack title
|
|
og "description" description
|
|
maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
|
|
og "site_name" =<< (Blog.get $name.$pack)
|
|
where
|
|
maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
|
|
|
|
instance HasCard Article.Article where
|
|
getCard (Article.Article {Article.title, Article.metadata}) = do
|
|
description <- pack <$> getDescription (Map.lookup "summary" metadata)
|
|
return $ Card {
|
|
cardType = "article"
|
|
, description
|
|
, image = (Map.lookup "featuredImage" metadata)
|
|
, DOM.Card.title
|
|
, urlPath = "/articles/" ++ title ++ ".html"
|
|
}
|
|
where
|
|
getDescription = maybe (Blog.get $name.$("A new article on " <>)) return
|
|
|
|
instance HasCard ArticlesList where
|
|
getCard al = do
|
|
cardTitle <- getTitle <$> Blog.get name
|
|
description <- pageTitle al
|
|
return $ Card {
|
|
cardType = "website"
|
|
, description
|
|
, image = Nothing
|
|
, DOM.Card.title = cardTitle
|
|
, urlPath = maybe "" ('/':) (tagged al) ++ file
|
|
}
|
|
where
|
|
getTitle name = maybe name ((name ++ " - ") ++) $ tagged al
|
|
file = '/' : (if full al then "all" else "index") ++ ".html"
|