Ugly JS desperate fix
This commit is contained in:
parent
dc9e7bc99d
commit
761e89f350
4 changed files with 64 additions and 57 deletions
|
@ -56,7 +56,8 @@ library
|
||||||
, containers >= 0.5.11 && < 0.7
|
, containers >= 0.5.11 && < 0.7
|
||||||
, directory >= 1.3.1 && < 1.4
|
, directory >= 1.3.1 && < 1.4
|
||||||
, filepath >= 1.4.2 && < 1.5
|
, filepath >= 1.4.2 && < 1.5
|
||||||
, lucid >= 2.8.0 && < 2.10
|
, blaze-html
|
||||||
|
, blaze-markup
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl >= 2.2.2 && < 2.3
|
||||||
, optparse-applicative >= 0.14.0 && < 0.17
|
, optparse-applicative >= 0.14.0 && < 0.17
|
||||||
, parsec >= 3.1.13 && < 3.2
|
, parsec >= 3.1.13 && < 3.2
|
||||||
|
|
82
src/DOM.hs
82
src/DOM.hs
|
@ -18,22 +18,28 @@ import Data.Map as Map (Map, toList)
|
||||||
import Data.Text (Text, pack, empty)
|
import Data.Text (Text, pack, empty)
|
||||||
import DOM.Card (HasCard)
|
import DOM.Card (HasCard)
|
||||||
import qualified DOM.Card as Card (make)
|
import qualified DOM.Card as Card (make)
|
||||||
import Lucid (
|
--import Lucid (
|
||||||
Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
|
-- Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
|
||||||
, h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
|
-- , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
|
||||||
, script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
|
-- , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
|
||||||
)
|
-- )
|
||||||
import Markdown (Markdown(..), MarkdownContent(..))
|
import Markdown (Markdown(..), MarkdownContent(..))
|
||||||
import Network.URL (URL)
|
import Network.URL (URL)
|
||||||
import Page (Page)
|
import Page (Page)
|
||||||
import Prelude hiding (head, lookup)
|
import Prelude hiding (div, head, id, lookup)
|
||||||
import Pretty ((.$))
|
import Pretty ((.$))
|
||||||
import System.FilePath.Posix ((</>), (<.>))
|
import System.FilePath.Posix ((</>), (<.>))
|
||||||
|
import Text.Blaze.Html5 as H (
|
||||||
|
(!), Html, ToValue(..), body, div, docTypeHtml, h2, head, li, meta, preEscapedText, script, text, title, ul
|
||||||
|
)
|
||||||
|
import Text.Blaze.Html5.Attributes (
|
||||||
|
charset, class_, id, src
|
||||||
|
)
|
||||||
|
|
||||||
type HtmlGenerator = HtmlT (ReaderT Blog IO)
|
type HtmlGenerator = ReaderT Blog IO Html
|
||||||
|
|
||||||
class HasCard a => PageType a where
|
class HasCard a => PageType a where
|
||||||
content :: a -> HtmlGenerator ()
|
content :: a -> HtmlGenerator
|
||||||
pathToRoot :: a -> FilePath
|
pathToRoot :: a -> FilePath
|
||||||
|
|
||||||
instance PageType Article where
|
instance PageType Article where
|
||||||
|
@ -47,17 +53,17 @@ instance PageType Page where
|
||||||
instance PageType ArticlesList where
|
instance PageType ArticlesList where
|
||||||
content al@(ArticlesList {full}) = do
|
content al@(ArticlesList {full}) = do
|
||||||
preview <- Article.preview <$> (asks $skin.$previewLinesCount)
|
preview <- Article.preview <$> (asks $skin.$previewLinesCount)
|
||||||
h2_ . toHtml =<< description al
|
h2_ . text =<< description al
|
||||||
ul_ $ do
|
ul_ $ do
|
||||||
asks hasRSS >>= rssLink
|
asks hasRSS >>= rssLink
|
||||||
li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
|
li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
|
||||||
div_ [class_ "articles"] (
|
div [class_ "articles"] (
|
||||||
mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
|
mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
otherLink =
|
otherLink =
|
||||||
toHtml <$> template (if full then "latestLink" else "allLink") []
|
toHtml <$> template (if full then "latestLink" else "allLink") []
|
||||||
rssLink :: Bool -> HtmlGenerator ()
|
rssLink :: Bool -> HtmlGenerator
|
||||||
rssLink True = do
|
rssLink True = do
|
||||||
(text, title) <- rssLinkTexts al
|
(text, title) <- rssLinkTexts al
|
||||||
li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
|
li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
|
||||||
|
@ -65,70 +71,68 @@ instance PageType ArticlesList where
|
||||||
|
|
||||||
pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
|
pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
|
||||||
|
|
||||||
mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
|
mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
|
||||||
mDContent raw base markdown@(Markdown {key, body}) =
|
mDContent raw base markdown@(Markdown {key, Markdown.body}) =
|
||||||
article_ [id_ $ pack key] (do
|
article_ ! id (toValue key) (do
|
||||||
header_ . h1_ $ mDLink raw base markdown
|
header_ . h1_ $ mDLink raw base markdown
|
||||||
pre_ . toHtml $ unlines body
|
pre_ . toHtml $ unlines body
|
||||||
)
|
)
|
||||||
|
|
||||||
mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
|
mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator
|
||||||
mDLink raw base (Markdown {Markdown.path, title}) = link $ toHtml title
|
mDLink raw base (Markdown {Markdown.path, Markdown.title}) = link $ toHtml title
|
||||||
where
|
where
|
||||||
link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
|
link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
|
||||||
|
|
||||||
prefix :: FilePath -> FilePath -> Text
|
prefix :: FilePath -> FilePath -> Text
|
||||||
prefix base = pack . (base </>)
|
prefix base = pack . (base </>)
|
||||||
|
|
||||||
tag :: FilePath -> String -> HtmlGenerator ()
|
tag :: FilePath -> String -> HtmlGenerator
|
||||||
tag base name =
|
tag base name =
|
||||||
a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
|
a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
|
||||||
|
|
||||||
defaultBanner :: FilePath -> HtmlGenerator ()
|
defaultBanner :: FilePath -> HtmlGenerator
|
||||||
defaultBanner base =
|
defaultBanner base =
|
||||||
div_ [id_ "header"] (
|
div ! id "header" $
|
||||||
a_ [href_ $ pack base] (
|
a_ [href_ $ pack base] (
|
||||||
h1_ . toHtml =<< asks name
|
h1_ . toHtml =<< asks name
|
||||||
)
|
)
|
||||||
)
|
|
||||||
|
|
||||||
faviconLink :: FilePath -> URL -> HtmlGenerator ()
|
faviconLink :: FilePath -> URL -> HtmlGenerator
|
||||||
faviconLink base url = link_ [
|
faviconLink base url = link_ [
|
||||||
rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
|
rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
|
||||||
]
|
]
|
||||||
|
|
||||||
optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
|
optional :: (a -> HtmlGenerator) -> Maybe a -> HtmlGenerator
|
||||||
optional = maybe (return ())
|
optional = maybe (return mempty)
|
||||||
|
|
||||||
navigationSection ::
|
navigationSection ::
|
||||||
Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator ()
|
Text -> String -> ((String, a) -> HtmlGenerator) -> Map String a -> HtmlGenerator
|
||||||
navigationSection sectionId templateKey generator collection
|
navigationSection sectionId templateKey generator collection
|
||||||
| null collection = return ()
|
| null collection = return ()
|
||||||
| otherwise =
|
| otherwise =
|
||||||
div_ [id_ sectionId, class_ "navigator"] (do
|
div ! id sectionId ! class_ "navigator" $ do
|
||||||
h2_ . toHtml =<< template templateKey []
|
h2 . toHtml =<< template templateKey []
|
||||||
ul_ . mapM_ (li_ . generator) $ Map.toList collection
|
ul $ (li . generator) <$> Map.toList collection
|
||||||
)
|
|
||||||
|
|
||||||
htmlDocument :: PageType a => a -> HtmlGenerator ()
|
htmlDocument :: PageType a => a -> HtmlGenerator
|
||||||
htmlDocument someContent =
|
htmlDocument someContent =
|
||||||
let base = pathToRoot someContent in
|
let base = pathToRoot someContent in
|
||||||
doctypehtml_ (do
|
docTypeHtml (do
|
||||||
head_ (do
|
H.head (do
|
||||||
meta_ [charset_ "utf-8"]
|
meta ! charset "utf-8"
|
||||||
title_ . toHtml =<< asks name
|
H.title . text =<< asks name
|
||||||
script_ [src_ $ prefix base "js/remarkable.min.js"] empty
|
script ! src (prefix base "js/remarkable.min.js") mempty
|
||||||
script_ [src_ $ prefix base "js/hablo.js"] empty
|
script ! src (prefix base "js/hablo.js") mempty
|
||||||
optional (faviconLink base) =<< (asks $skin.$favicon)
|
optional (faviconLink base) =<< (asks $skin.$favicon)
|
||||||
optional (Card.make someContent) =<< (asks $urls.$cards)
|
optional (Card.make someContent) =<< (asks $urls.$cards)
|
||||||
optional toHtmlRaw =<< (asks $skin.$head)
|
optional preEscapedText =<< (asks $skin.$Blog.head)
|
||||||
)
|
)
|
||||||
body_ (do
|
H.body (do
|
||||||
maybe (defaultBanner base) toHtmlRaw =<< (asks $skin.$banner)
|
maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
|
||||||
asks tags >>= navigationSection "tags" "tagsList"
|
asks tags >>= navigationSection "tags" "tagsList"
|
||||||
(\(key, _) -> tag base key)
|
(\(key, _) -> tag base key)
|
||||||
asks pages >>= navigationSection "pages" "pagesList"
|
asks pages >>= navigationSection "pages" "pagesList"
|
||||||
(\(_, page) -> mDLink False base $ getMarkdown page)
|
(\(_, page) -> mDLink False base $ getMarkdown page)
|
||||||
div_ [id_ "contents"] $ content someContent
|
div ! id "contents" $ content someContent
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
|
@ -17,14 +17,16 @@ import Control.Applicative ((<|>))
|
||||||
import Control.Monad.Reader (asks)
|
import Control.Monad.Reader (asks)
|
||||||
import qualified Data.Map as Map (lookup)
|
import qualified Data.Map as Map (lookup)
|
||||||
import Data.Text (Text, pack)
|
import Data.Text (Text, pack)
|
||||||
import Lucid (HtmlT, content_, meta_)
|
--import Lucid (HtmlT, content_, meta_)
|
||||||
import Lucid.Base (makeAttribute)
|
--import Lucid.Base (makeAttribute)
|
||||||
import Markdown (MarkdownContent(..), metadata)
|
import Markdown (MarkdownContent(..), metadata)
|
||||||
import Network.URL (URL)
|
import Network.URL (URL)
|
||||||
import qualified Markdown (Markdown(..))
|
import qualified Markdown (Markdown(..))
|
||||||
import Page (Page(..))
|
import Page (Page(..))
|
||||||
import Pretty ((.$))
|
import Pretty ((.$))
|
||||||
import System.FilePath.Posix ((</>), (<.>))
|
import System.FilePath.Posix ((</>), (<.>))
|
||||||
|
import Text.Blaze.Html5 ((!), AttributeValue, Html, ToValue(..), meta, customAttribute)
|
||||||
|
import Text.Blaze.Html5.Attributes as A (content)
|
||||||
|
|
||||||
class HasCard a where
|
class HasCard a where
|
||||||
cardType :: Renderer m => a -> m Text
|
cardType :: Renderer m => a -> m Text
|
||||||
|
@ -33,14 +35,13 @@ class HasCard a where
|
||||||
title :: Renderer m => a -> m String
|
title :: Renderer m => a -> m String
|
||||||
urlPath :: Renderer m => a -> m String
|
urlPath :: Renderer m => a -> m String
|
||||||
|
|
||||||
og :: Applicative m => Text -> Text -> HtmlT m ()
|
og :: Applicative m => AttributeValue -> Text -> m Html
|
||||||
og attribute value =
|
og attribute t =
|
||||||
meta_ [
|
pure $ meta
|
||||||
makeAttribute "property" $ "og:" <> attribute
|
! (customAttribute "property" $ "og:" <> attribute)
|
||||||
, content_ value
|
! content (toValue t)
|
||||||
]
|
|
||||||
|
|
||||||
make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
|
make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html
|
||||||
make element siteURL = do
|
make element siteURL = do
|
||||||
og "url" . (pathOn siteURL) =<< urlPath element
|
og "url" . (pathOn siteURL) =<< urlPath element
|
||||||
og "type" =<< cardType element
|
og "type" =<< cardType element
|
||||||
|
@ -49,7 +50,7 @@ make element siteURL = do
|
||||||
maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
|
maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
|
||||||
og "site_name" =<< (asks $name.$pack)
|
og "site_name" =<< (asks $name.$pack)
|
||||||
where
|
where
|
||||||
maybeImage = maybe (return ()) (og "image" . defaultOn siteURL)
|
maybeImage = maybe (return mempty) (og "image" . defaultOn siteURL)
|
||||||
|
|
||||||
mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
|
mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
|
||||||
mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
|
mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
|
||||||
|
|
|
@ -19,13 +19,14 @@ import Data.Map ((!))
|
||||||
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
|
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
|
||||||
import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
|
import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
|
||||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||||
import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
|
--import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
|
||||||
import Lucid.Base (makeAttribute)
|
import Lucid.Base (makeAttribute)
|
||||||
import Markdown (Markdown(..))
|
import Markdown (Markdown(..))
|
||||||
import Pretty ((.$))
|
import Pretty ((.$))
|
||||||
import System.FilePath.Posix ((</>), (<.>))
|
import System.FilePath.Posix ((</>), (<.>))
|
||||||
|
import Text.Blaze.Html (Html)
|
||||||
|
|
||||||
prolog :: Monad m => HtmlT m ()
|
prolog :: Monad m => m Html
|
||||||
prolog = toHtmlRaw ("<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
|
prolog = toHtmlRaw ("<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
|
||||||
|
|
||||||
version_ :: Text -> Attribute
|
version_ :: Text -> Attribute
|
||||||
|
@ -58,7 +59,7 @@ item_ = term "item"
|
||||||
pubDate_ :: Term arg result => arg -> result
|
pubDate_ :: Term arg result => arg -> result
|
||||||
pubDate_ = term "pubDate"
|
pubDate_ = term "pubDate"
|
||||||
|
|
||||||
articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
|
articleItem :: Monad m => AbsoluteURL -> Article -> m Html
|
||||||
articleItem siteURL (Article (Markdown {path, metadata, title})) =
|
articleItem siteURL (Article (Markdown {path, metadata, title})) =
|
||||||
item_ $ do
|
item_ $ do
|
||||||
title_ $ toHtml title
|
title_ $ toHtml title
|
||||||
|
@ -69,7 +70,7 @@ articleItem siteURL (Article (Markdown {path, metadata, title})) =
|
||||||
formatTime defaultTimeLocale rfc822DateFormat
|
formatTime defaultTimeLocale rfc822DateFormat
|
||||||
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
|
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
|
||||||
|
|
||||||
feed :: Renderer m => AbsoluteURL -> ArticlesList -> HtmlT m ()
|
feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html
|
||||||
feed siteURL al@(ArticlesList {collection}) = do
|
feed siteURL al@(ArticlesList {collection}) = do
|
||||||
prolog
|
prolog
|
||||||
rss_ [version, content, atom] $ do
|
rss_ [version, content, atom] $ do
|
||||||
|
|
Loading…
Reference in a new issue