92 lines
3.0 KiB
Haskell
92 lines
3.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM.Card (
|
|
HasCard(..)
|
|
, make
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
import ArticlesList (ArticlesList(..))
|
|
import qualified ArticlesList (description)
|
|
import Blog (Blog(..), Renderer, Skin(..), template)
|
|
import Collection (Collection(..))
|
|
import qualified Collection (title)
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.Reader (asks)
|
|
import qualified Data.Map as Map (lookup)
|
|
import Data.Text (Text, pack)
|
|
import Lucid (HtmlT, content_, meta_)
|
|
import Lucid.Base (makeAttribute)
|
|
import Markdown (MarkdownContent(..), metadata)
|
|
import qualified Markdown (Markdown(..))
|
|
import Page (Page(..))
|
|
import Pretty ((.$))
|
|
import System.FilePath.Posix ((</>), (<.>))
|
|
|
|
class HasCard a where
|
|
cardType :: Renderer m => a -> m Text
|
|
description :: Renderer m => a -> m Text
|
|
image :: Renderer m => a -> m (Maybe String)
|
|
title :: Renderer m => a -> m String
|
|
urlPath :: Renderer m => a -> m String
|
|
|
|
og :: Applicative m => Text -> Text -> HtmlT m ()
|
|
og attribute value =
|
|
meta_ [
|
|
makeAttribute "property" $ "og:" <> attribute
|
|
, content_ value
|
|
]
|
|
|
|
make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
|
|
make element siteURL = do
|
|
og "url" . sitePrefix =<< urlPath element
|
|
og "type" =<< cardType element
|
|
og "title" . pack =<< title element
|
|
og "description" =<< description element
|
|
maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
|
|
og "site_name" =<< (asks $name.$pack)
|
|
where
|
|
maybeImage = maybe (return ()) (og "image" . sitePrefix)
|
|
sitePrefix = pack . (siteURL </>)
|
|
|
|
mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
|
|
mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown
|
|
|
|
mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
|
|
mDTitle = return . Markdown.title . getMarkdown
|
|
|
|
mDUrlPath :: (Renderer m, MarkdownContent a) => a -> m String
|
|
mDUrlPath a = return $ Markdown.path (getMarkdown a) <.> "html"
|
|
|
|
mDDescription :: (Renderer m, MarkdownContent a) => String -> a -> m Text
|
|
mDDescription key =
|
|
getDescription . Map.lookup "summary" . metadata . getMarkdown
|
|
where
|
|
getDescription = maybe defaultDescription (return . pack)
|
|
defaultDescription = asks name >>= template key . \v -> [("name", pack v)]
|
|
|
|
instance HasCard Article where
|
|
cardType _ = return "article"
|
|
description = mDDescription "articleDescription"
|
|
image = mDImage
|
|
title = mDTitle
|
|
urlPath = mDUrlPath
|
|
|
|
instance HasCard Page where
|
|
cardType _ = return "website"
|
|
description = mDDescription "pageDescription"
|
|
image = mDImage
|
|
title = mDTitle
|
|
urlPath = mDUrlPath
|
|
|
|
instance HasCard ArticlesList where
|
|
cardType _ = return "website"
|
|
description = ArticlesList.description
|
|
image _ = return Nothing
|
|
title (ArticlesList {collection}) = Collection.title collection
|
|
urlPath al@(ArticlesList {collection}) =
|
|
return $ maybe "" id (tag collection) </> file
|
|
where
|
|
file = (if full al then "all" else "index") <.> ".html"
|