Implement JS navigation

hablo.cabal

@@ -15,7 +15,8 @@ maintainer:          tissevert+devel@marvid.fr
 -- copyright:
 category:            Web
 extra-source-files:  CHANGELOG.md
-data-files:          js/main.js
+build-type:          Simple
+data-files:          js/*.js
 
 executable hablo
   main-is:             Main.hs
@@ -41,6 +42,7 @@ executable hablo
                      , lucid
                      , mtl
                      , optparse-applicative
+                     , parsec
                      , text
                      , unix
   ghc-options:         -Wall

js/domRenderer.js

@@ -0,0 +1,78 @@
+function DomRenderer(modules) {
+	return {
+		article: article,
+		articlesList: articlesList,
+		replaceMarkdown: replaceMarkdown
+	};
+
+	function replaceMarkdown() {
+		var div = document.getElementById('contents');
+		if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') {
+			convertArticle(div.children[0]);
+		} else {
+			var articles = div.getElementsByClassName('articles')[0];
+			if(articles != undefined) {
+				for(var i = 0; i < articles.children.length; i++) {
+					convertArticle(articles.children[i]);
+				}
+			} else {
+				console.log('No articles found for this page');
+			}
+		}
+	}
+
+	function convertArticle(article) {
+		var header = article.getElementsByTagName('header')[0];
+		var text = article.getElementsByTagName('pre')[0];
+		if(text != undefined) {
+			article.replaceChild(getDiv(text.innerText), text);
+		} else {
+			console.log('No content found for this article');
+		}
+	}
+
+	function getDiv(markdown) {
+		return modules.dom.make('div', {
+			innerHTML: modules.md.render(markdown)
+		});
+	}
+
+	function article(url, markdown, limit) {
+		var headerEnd = markdown.search(/\n\n/);
+		var header = getDiv(markdown.slice(0, headerEnd));
+		var lines = markdown.slice(headerEnd+2).split(/\n/);
+		var div = getDiv(lines.slice(0, limit).join('\n'));
+		var title = header.getElementsByTagName('h1')[0];
+		return title == undefined ? null : modules.dom.make('article', {}, [
+			modules.dom.make('header', {}, [
+				modules.dom.make('a', {class: (limit != undefined ? 'navigation' : []), href: url}, [title])
+			]),
+			div
+		]);
+	}
+
+	function pageTitle(tag, all) {
+		return (all ? 'All' : 'Latest') + ' articles' + (tag != undefined ? ' tagged ' + tag : '');
+	}
+
+	function otherUrl(tag, all) {
+		var path = [tag, all ? null : 'all.html'];
+		return '/' + path.filter(modules.fun.defined).join('/');
+	}
+
+	function articlesList(tag, all) {
+		return function(articlePreviews) {
+			return [
+				modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
+				modules.dom.make('p', {}, [
+					modules.dom.make('a', {
+						class: 'navigation',
+						innerText: all ? 'See only latest' : 'See all',
+						href: otherUrl(tag, all)
+					})
+				]),
+				modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))
+			];
+		};
+	}
+}

js/main.js

@@ -1,3 +1,12 @@
 window.addEventListener('load', function() {
-  console.log("Hablo loaded");
+	var async = unitJS.Async();
+	var cache = unitJS.Cache();
+	var dom = unitJS.Dom();
+	var fun = unitJS.Fun();
+	var md = new Remarkable({html: true});
+	md.block.ruler.enable(['footnote']);
+	var domRenderer = DomRenderer({fun: fun, md: md, dom: dom});
+	var navigation = Navigation({async: async, cache: cache, fun: fun, md: md, dom: dom, domRenderer: domRenderer});
+	domRenderer.replaceMarkdown();
+	navigation.hijackLinks();
 });

js/navigation.js

@@ -0,0 +1,106 @@
+function Navigation(modules) {
+	var articles = modules.cache.make(function(url) {
+		return modules.async.bind(
+			modules.async.http({method: 'GET', url: url}),
+			function(queryResult) {
+				if(queryResult.status == 200) {
+					return modules.async.wrap(queryResult.responseText);
+				} else {
+					return modules.async.fail(
+						"Could not load article " + url + " (" + queryResult.status + " " + queryResult.statusText + ")"
+					);
+				}
+			}
+		);
+	});
+	window.addEventListener('popstate', function(e) {navigate(e.state.url);});
+	history.replaceState({url: window.location.pathname}, 'Blog - title', window.location.pathname);
+	return {
+		hijackLinks: hijackLinks
+	};
+
+	function hijackLinks(domElem) {
+		domElem = domElem || document;
+		var links = domElem.getElementsByTagName('a');
+		for(var i = 0; i < links.length; i++) {
+			var a = links[i];
+			if(a.classList.contains("navigation")) {
+				a.addEventListener('click', visit(a.getAttribute("href")));
+			}
+		}
+	}
+
+	function visit(url) {
+		return function(e) {
+			e.preventDefault();
+			history.pushState({url: url}, 'Blog - title', url);
+			navigate(url);
+		};
+	}
+
+	function navigate(url) {
+		var path = url.split("/").slice(1);
+		if(blog.tags[path[0]] != undefined) {
+			show(getArticlesList(path[0], path[1] == "all.html"));
+		} else if(path[0].length > 0 && !path[0].match(/\.html$/)) {
+			show(getArticle(url.replace(/html$/, 'md')));
+		} else {
+			show(getArticlesList(null, path[0] == "all.html"));
+		}
+	}
+
+	function getArticle(url) {
+		return modules.async.bind(
+			articles.get(url),
+			modules.async.map(
+				function(contents) {return [modules.domRenderer.article(url, contents)];}
+			)
+		);
+	}
+
+	function preview(articleId) {
+		var source = blog.articles[articleId].source;
+		return modules.async.bind(
+			articles.get(source),
+			function(contents) {
+				return modules.async.wrap(
+					modules.domRenderer.article(
+						source.replace(/md$/, 'html'),
+						contents,
+						blog.skin.previewLinesCount
+					)
+				);
+			}
+		);
+	}
+
+	function articleIds(tag, all) {
+		var ids = tag != undefined ? blog.tags[tag] : Object.keys(blog.articles);
+		ids.sort(function(idA, idB) {return blog.articles[idB].date - blog.articles[idA].date;});
+		return ids.slice(0, all ? undefined : blog.skin.previewArticlesCount);
+	}
+
+	function getArticlesList(tag, all) {
+		return modules.async.bind(
+			modules.async.parallel.apply(null, articleIds(tag, all).map(preview)),
+			modules.async.map(modules.domRenderer.articlesList(tag, all))
+		);
+	}
+
+	function show(contents) {
+		modules.async.run(
+			modules.async.bind(
+				contents,
+				modules.async.map(function (domElems) {
+					domElems = domElems.filter(modules.fun.defined);
+					var div = document.getElementById('contents');
+					modules.dom.clear(div);
+					for(var i = 0; i < domElems.length; i++) {
+						div.appendChild(domElems[i]);
+					}
+					hijackLinks(div);
+				})
+			)
+		);
+	}
+}

src/Article.hs

@@ -1,53 +1,73 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{- LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Article (
       Article(..)
     , at
+    , preview
+    , titleP
   ) where
 
-import Control.Monad.State (evalState, modify, state)
+import Data.Map (Map)
+import qualified Data.Map as Map (fromList)
 import System.FilePath (dropExtension)
 import System.Posix.Types (FileID)
 import System.Posix.Files (FileStatus, getFileStatus, fileID)
+import Text.ParserCombinators.Parsec (
+      ParseError
+    , Parser
+    , (<|>)
+    , anyChar, char, count, endBy, eof, many, many1, noneOf, oneOf, option, parse, skipMany, spaces, string, try
+  )
 
 data Article = Article {
       urlPath :: String
     , fileStatus :: FileStatus
     , title :: String
-    , preview :: String
+    , metadata :: Map String String
-    , fullContents :: String
+    , body :: [String]
   }
 
-getTitle :: [String] -> (String, [String])
+articleP :: Parser (String, Map String String, [String])
-getTitle [] = ("", [])
+articleP =
-getTitle (('#':' ':aTitle):rest) = (aTitle, rest)
+  skipMany eol *> headerP <* skipMany eol <*> (lines <$> many anyChar <* eof)
-getTitle (a:b:l)
+  where
-  | length a == length b && (all (== '#') b || all (== '=') b) = (a, b:l)
+    headerP =
-  | otherwise = getTitle (b:l)
+        try ((,,) <$> titleP <* many eol <*> metadataP)
-getTitle (_:rest) = getTitle rest
+      <|> flip (,,) <$> metadataP  <* many eol<*> titleP
 
-parseBegining :: Int -> String -> (String, String)
+metadataP :: Parser (Map String String)
-parseBegining linesCount = evalState (do
+metadataP = Map.fromList <$> option [] (
-    theTitle <- state getTitle
+    metaSectionSeparator *> many eol *>
-    modify $ dropWhile $ not . null
+    (try keyVal) `endBy` (many1 eol)
-    modify $ dropWhile null
+    <* metaSectionSeparator
-    thePreview <- state $ splitAt linesCount
+  )
-    return (theTitle, unlines thePreview)
+  where
-  ) . lines
+    metaSectionSeparator = count 3 (oneOf "~-") *> eol
+    keyVal = (,) <$> (no ": " <* spaces <* char ':' <* spaces) <*> no "\r\n"
 
-at :: Int -> FilePath -> IO (FileID, Article)
+titleP :: Parser String
-at linesCount filePath = do
+titleP = try (singleLine <|> underlined)
+  where
+    singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
+    underlined =
+      no "\r\n" <* eol
+      >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
+
+eol :: Parser String
+eol = try (string "\r\n") <|> string "\r" <|> string "\n"
+
+no :: String -> Parser String
+no = many1 . noneOf
+
+at :: FilePath -> IO (Either ParseError (FileID, Article))
+at filePath = do
   fileStatus <- getFileStatus filePath
-  fullContents <- readFile filePath
+  fmap (makeArticle fileStatus) . parse articleP filePath <$> readFile filePath
-  let (title, preview) = parseBegining linesCount fullContents
+  where
-  return (
+    makeArticle fileStatus (title, metadata, body) = (
-        fileID fileStatus
+          fileID fileStatus
-      , Article {
+        , Article {urlPath = dropExtension filePath, fileStatus, title, body, metadata}
-              urlPath = dropExtension filePath
+      )
-            , fileStatus
-            , title
-            , preview
-            , fullContents
-          }
-    )
 
+preview :: Int -> Article -> Article
+preview linesCount article = article {body = take linesCount $ body article}

src/Blog.hs

@@ -15,6 +15,7 @@ import Blog.Skin (Skin(..))
 import qualified Blog.Skin as Skin (build)
 import Control.Monad ((>=>), filterM, forM)
 import Control.Monad.Reader (MonadReader, ask)
+import Data.Either (rights)
 import Data.Map (Map)
 import qualified Data.Map as Map (fromList, member)
 import Data.Set (Set)
@@ -38,12 +39,12 @@ data Blog = Blog {
 get :: MonadReader Blog m => (Blog -> a) -> m a
 get = (<$> ask)
 
-findArticles :: Int -> FilePath -> IO (Map FileID Article)
+findArticles :: FilePath -> IO (Map FileID Article)
-findArticles linesCount =
+findArticles =
   Files.find
   >=> filterM isMarkDownFile
-  >=> mapM (Article.at linesCount)
+  >=> mapM Article.at
-  >=> return . Map.fromList
+  >=> return . Map.fromList . rights
   where
     isMarkDownFile path = do
       let correctExtension = takeExtension path == ".md"
@@ -65,7 +66,7 @@ build :: Arguments -> IO Blog
 build arguments = withCurrentDirectory root $ do
   let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ Arguments.name arguments
   skin <- Skin.build name arguments
-  articles <- findArticles (previewLinesCount skin) articlesPath
+  articles <- findArticles articlesPath
   tags <- Map.fromList . filter (not . Set.null . snd)
     <$> (Files.find (articlesPath </> "tags") >>= mapM (articles `tagged`))
   return $ Blog {

src/Dom.hs

@@ -5,6 +5,7 @@ module Dom (
   ) where
 
 import Article (Article(..))
+import qualified Article (preview)
 import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
 import Blog (Blog(..), Skin(..))
 import qualified Blog (get)
@@ -29,11 +30,7 @@ instance Page Article where
     ("A new article on " <>) <$> Blog.get name
     >>= makeCard title
 
-  content (Article {fullContents, urlPath}) =
+  content = article True
-    article_ (do
-        a_ [href_ . pack $ "/" </> urlPath <.> "md"] "Raw"
-        pre_ $ toHtml fullContents
-      )
 
 instance Page ArticlesList where
   card al = do
@@ -41,9 +38,23 @@ instance Page ArticlesList where
     makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) (pageTitle al)
 
   content al@(ArticlesList {featured}) = do
+    preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
     h2_ . toHtml . pack $ pageTitle al
     p_ . navigationA [href_ . pack $ otherUrl al] . toHtml . pack $ otherLink al
-    div_ [class_ "articles"] (mapM_ previewArticle featured)
+    div_ [class_ "articles"] (
+        mapM_ (article False . preview) featured
+      )
+
+article :: Bool -> Article -> HtmlGenerator ()
+article raw (Article {body, title, urlPath}) =
+  article_ (do
+      header_ (do
+          aElem [href_ . pack $ "/" </> urlPath <.> extension] . h1_ $ toHtml title
+        )
+      pre_ . toHtml $ unlines body
+    )
+  where
+    (aElem, extension) = if raw then (a_, "md") else (navigationA, "html")
 
 makeCard :: String -> String -> HtmlGenerator ()
 makeCard title description = do
@@ -57,13 +68,6 @@ makeCard title description = do
 navigationA :: Term arg result => arg -> result
 navigationA = "a" `termWith` [class_ "navigation"]
 
-previewArticle :: Article -> HtmlGenerator ()
-previewArticle (Article {urlPath, title, preview}) =
-  article_ (do
-    navigationA [href_ . pack $ "/" </> urlPath <.> "html"] . h3_ $ toHtml title
-    pre_ $ toHtml preview
-  )
-
 tag :: String -> HtmlGenerator ()
 tag tagName = li_ (navigationA [href_ $ pack ("/" </> tagName)] $ toHtml tagName)
 
@@ -84,8 +88,8 @@ page aPage =
       head_ (do
           meta_ [charset_ "utf-8"]
           title_ . toHtml =<< Blog.get name
-          script_ [src_ "/UnitJS/async.js"] empty
+          script_ [src_ "/js/unit.js"] empty
-          script_ [src_ "/UnitJS/dom.js"] empty
+          script_ [src_ "/js/remarkable.min.js"] empty
           script_ [src_ "/js/hablo.js"] empty
           maybe (toHtml empty) faviconLink =<< (Blog.get $skin.$favicon)
           card aPage

src/JSON.hs

@@ -7,7 +7,7 @@ module JSON (
 import Article (Article)
 import qualified Article (Article(..))
 import Blog (Blog)
-import qualified Blog (Blog(..))
+import qualified Blog (Blog(..), Skin(..))
 import Control.Monad.Reader (ReaderT, ask)
 import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
 import Data.ByteString.Lazy (ByteString)
@@ -24,16 +24,25 @@ type ArticleID = Int
 data ArticleExport = ArticleExport {
       source :: String
     , title :: String
-    , date :: EpochTime
+    , metadata :: Map String String
     , tagged :: [String]
   } deriving (Generic)
 
 instance ToJSON ArticleExport where
   toEncoding = genericToEncoding defaultOptions
 
+data SkinExport = SkinExport {
+      previewArticlesCount :: Int
+    , previewLinesCount :: Int
+  } deriving (Generic)
+
+instance ToJSON SkinExport where
+  toEncoding = genericToEncoding defaultOptions
+
 data BlogDB = BlogDB {
       articles :: Map ArticleID ArticleExport
     , tags :: Map String [ArticleID]
+    , skin :: SkinExport
   } deriving (Generic)
 
 instance ToJSON BlogDB where
@@ -47,7 +56,7 @@ export :: Blog -> FileID -> Article -> ArticleExport
 export blog fileID article = ArticleExport {
       source = "/" </> Article.urlPath article <.> "md"
     , title = Article.title article
-    , date = modificationTime $ Article.fileStatus article
+    , metadata = Article.metadata article
     , tagged = Map.keys . Map.filter (Set.member fileID) $ Blog.tags blog
   }
 
@@ -58,4 +67,8 @@ exportBlog = do
   return . encode $ BlogDB {
         articles = mapKeys (reindex !) $ mapWithKey (export blog) (Blog.articles blog)
       , tags = fmap (reindex !) . Set.elems <$> Blog.tags blog
+      , skin = SkinExport {
+          previewArticlesCount = Blog.previewArticlesCount $ Blog.skin blog
+        , previewLinesCount = Blog.previewLinesCount $ Blog.skin blog
+      }
     }