Initial draft

.gitignore

@@ -0,0 +1,2 @@
+/dist-newstyle/*
+.ghc.environment.*

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hablo
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2019, Tissevert
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Tissevert nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1,3 @@
+# Hablo
+
+Hablo is a minimalist static blog generator. The idea is to keep all your content in Markdown and hablo will only generate the static pages needed to list them.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hablo.cabal

@@ -0,0 +1,39 @@
+cabal-version:       2.4
+-- Initial package description 'hablo.cabal' generated by 'cabal init'.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name:                hablo
+version:             0.1.0.0
+synopsis:            A minimalist static blog generator
+-- description:
+homepage:            https://git.marvid.fr/Tissevert/hablo
+-- bug-reports:
+license:             BSD-3-Clause
+license-file:        LICENSE
+author:              Tissevert
+maintainer:          tissevert+devel@marvid.fr
+-- copyright:
+category:            Web
+extra-source-files:  CHANGELOG.md
+
+executable hablo
+  main-is:             Main.hs
+  other-modules:       Arguments
+                     , Blog
+                     , Dom
+                     , JSON
+  -- other-extensions:
+  build-depends:       aeson
+                     , base ^>=4.12.0.0
+                     , bytestring
+                     , containers
+                     , directory
+                     , filepath
+                     , lucid
+                     , mtl
+                     , optparse-applicative
+                     , text
+                     , unix
+  ghc-options:         -Wall
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Arguments.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Arguments (
+      Arguments(..)
+    , Configuration
+    , getConfiguration
+  ) where
+
+import Options.Applicative
+import System.FilePath.Posix (dropTrailingPathSeparator, isValid, takeDirectory, takeFileName)
+--import System.Directory (doesDirectoryExist)
+
+data Arguments a b = Arguments {
+      sourceDir :: FilePath
+    , outputDir :: a
+    , blogName :: b
+    , previewCount :: Int
+  }
+
+type InputArguments = Arguments (Maybe FilePath) (Maybe String)
+type Configuration = Arguments FilePath String
+
+arguments :: Parser InputArguments
+arguments = Arguments
+  <$> argument directory (metavar "INPUT_DIR")
+  <*> option (optional directory) (
+          metavar "OUTPUT_DIR"
+        <> value Nothing
+        <> short 'o'
+        <> long "output"
+        <> help "directory in which to generate the blog"
+      )
+  <*> option (optional str) (
+          metavar "BLOG_NAME"
+        <> value Nothing
+        <> short 'n'
+        <> long "name"
+        <> help "name of the blog"
+      )
+  <*> option auto (
+          metavar "PREVIEW_COUNT"
+        <> value 3
+        <> short 'p'
+        <> long "preview-count"
+        <> help "number of articles listed on the page of each category"
+      )
+
+{-
+existingDirectory :: ReadM FilePath
+existingDirectory = eitherReader $ \path ->
+  if doesDirectoryExist path
+    then Right path
+    else Left "The input directory must be an existing path"
+-}
+
+directory :: ReadM FilePath
+directory = eitherReader $ \path ->
+  if isValid path
+    then Right $ dropTrailingPathSeparator path
+    else Left "This string doesn't represent a valid path"
+
+getConfiguration :: IO Configuration
+getConfiguration = do
+  invocation <- execParser $
+    info (arguments <**> helper)
+      ( fullDesc
+      )
+  let outputDirOrDefault = maybe (takeDirectory $ sourceDir invocation) id (outputDir invocation)
+  let blogNameOrDefault = maybe (takeFileName outputDirOrDefault) id (blogName invocation)
+  return $ invocation {
+        outputDir = outputDirOrDefault
+      , blogName = blogNameOrDefault
+    }

src/Blog.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Blog (
+      Article(..)
+    , Blog(..)
+    , get
+  ) where
+
+import Arguments (Arguments(..), Configuration)
+import Control.Monad ((>=>), filterM, forM)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (MonadReader(..), ReaderT)
+import Data.Map (Map)
+import qualified Data.Map as Map (fromList, member)
+import Data.Set (Set)
+import qualified Data.Set as Set (empty, null, singleton, union)
+import System.Directory (doesFileExist, listDirectory)
+import System.FilePath.Posix ((</>), takeExtension, takeFileName)
+import System.Posix.Types (FileID)
+import System.Posix.Files (FileStatus, getFileStatus, fileID)
+
+data Article = Article {
+      filePath :: FilePath
+    , fileStatus :: FileStatus
+  }
+
+type Collection = Map FileID Article
+
+data Blog = Blog {
+      articles :: Collection
+    , name :: String
+    , tags :: Map String (Set FileID)
+  }
+
+find :: MonadIO m => FilePath -> m [FilePath]
+find path = 
+  prefix <$> liftIO (listDirectory path)
+  where
+    prefix = ((path </>) <$>)
+
+article :: MonadIO m => FilePath -> m (FileID, Article)
+article filePath = do
+  fileStatus <- liftIO $ getFileStatus filePath
+  return (fileID fileStatus, Article { filePath, fileStatus })
+
+findArticles :: MonadIO m => FilePath -> m (Map FileID Article)
+findArticles =
+  find >=> filterM isMarkDownFile >=> mapM article >=> return . Map.fromList
+  where
+    isMarkDownFile path = do
+      let correctExtension = takeExtension path == ".md"
+      (correctExtension &&) <$> liftIO (doesFileExist path)
+
+tagged :: MonadIO m => Collection -> FilePath -> m (String, Set FileID)
+tagged collection path = do
+  links <- find path
+  fileIDs <- forM links $ \link -> do
+    fileExists <- liftIO $ doesFileExist link
+    if fileExists
+      then do
+        inode <- fileID <$> liftIO (getFileStatus link)
+        return $ if Map.member inode collection then Set.singleton inode else Set.empty
+      else return Set.empty
+  return (takeFileName path, foldl Set.union Set.empty fileIDs)
+
+get :: ReaderT Configuration IO Blog
+get = do
+  path <- sourceDir <$> ask
+  articles <- findArticles path
+  name <- blogName <$> ask
+  tags <- Map.fromList . filter (not . Set.null . snd)
+    <$> (find (path </> "tags") >>= mapM (articles `tagged`))
+  return $ Blog { articles , name, tags }

src/Dom.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Dom (
+    generate
+  ) where
+
+import Arguments (Arguments(..), Configuration)
+import Blog (Article(..), Blog(..))
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (MonadReader(..), ReaderT)
+import Data.List (sortOn)
+import qualified Data.Map as Map (elems, filterWithKey, keys, toList)
+import Data.Ord (Down(..))
+import qualified Data.Set as Set (member)
+import Data.Text (pack, empty)
+import Lucid
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath.Posix ((</>))
+import System.Posix.Files (modificationTime)
+
+data Page = Page {
+      category :: Maybe String
+    , full :: Bool
+    , urlPath :: FilePath
+    , articlesFeatured :: [Article]
+  }
+
+previewArticle :: Article -> Html ()
+previewArticle article =
+  article_ (do
+    h1_ "Some Article"
+    pre_ . toHtml $ filePath article
+  )
+
+showTag :: String -> Html ()
+showTag tag = li_ (a_ [href_ $ pack ("/" </> tag)] $ toHtml tag)
+
+render :: Page -> Blog -> Html ()
+render (Page {category, full, articlesFeatured}) blog =
+  doctypehtml_ (do
+      head_ (do
+          meta_ [charset_ "utf-8"]
+          title_ . toHtml $ name blog
+          script_ [src_ "/UnitJS/async.js"] empty
+          script_ [src_ "/UnitJS/dom.js"] empty
+        )
+      body_ (do
+          div_ [id_ "header"] (return ())
+          div_ [id_ "navigator"] (do
+              h1_ "Tags"
+              ul_ (mapM_ showTag (Map.keys $ tags blog))
+            )
+          div_ [id_ "contents"] (do
+              h1_ $ toHtml pageTitle
+              div_ [class_ "articles"] (mapM_ previewArticle articlesFeatured)
+            )
+        )
+    )
+  where
+    pageTitle =
+      if full then "All" else "Latest" ++ " articles" ++ maybe "" (" tagged " ++) category
+
+generateCollection :: (Maybe String, FilePath, [Article]) -> Blog -> ReaderT Configuration IO ()
+generateCollection (_, _, []) _ = return ()
+generateCollection (category, path, articlesFeatured) blog = do
+  n <- previewCount <$> ask
+  liftIO $ createDirectoryIfMissing False path
+  forM_ (pages n) $ \page ->
+    liftIO $ renderToFile (urlPath page) (render page blog)
+  where
+    pages n = [
+          Page {
+              category
+            , full = True
+            , urlPath = path </> "all.html"
+            , articlesFeatured
+          }
+        , Page {
+              category
+            , full = False
+            , urlPath = path </> "index.html"
+            , articlesFeatured = take n articlesFeatured
+          }
+      ]
+
+generate :: Blog -> ReaderT Configuration IO ()
+generate blog@(Blog {articles, tags}) = do
+  path <- outputDir <$> ask
+  generateCollection (Nothing, path, sortByDate $ Map.elems articles) blog
+  forM_ (Map.toList tags) $ \(tag, tagged) ->
+    generateCollection (Just tag, path </> tag, sortByDate $ getArticles tagged) blog
+  where
+    getArticles tagged = Map.elems $ Map.filterWithKey (\k _ -> Set.member k tagged) articles
+    sortByDate = sortOn (Down . modificationTime . fileStatus)

src/JSON.hs

@@ -0,0 +1,17 @@
+module JSON (
+    generate
+  ) where
+
+import Arguments (Arguments(..), Configuration)
+import Blog (Blog(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Reader (MonadReader(..), ReaderT)
+import Data.Aeson
+import Data.ByteString.Lazy (writeFile)
+import System.FilePath.Posix ((</>))
+import Prelude hiding (writeFile)
+
+generate :: Blog -> ReaderT Configuration IO ()
+generate _ = do
+  path <- outputDir <$> ask
+  liftIO $ writeFile (path </> "articles.json") (encode $ object [])

src/Main.hs

@@ -0,0 +1,17 @@
+{- LANGUAGE NamedFieldPuns #-}
+module Main where
+
+import Arguments (getConfiguration)
+import qualified Blog (get)
+import qualified Dom (generate)
+import qualified JSON (generate)
+import Control.Monad.Reader (runReaderT)
+
+main :: IO ()
+main = do
+  getConfiguration
+  >>= runReaderT (do
+    blog <- Blog.get
+    Dom.generate blog
+    JSON.generate blog
+  )