From 0ca01da4d3b764984d1db2663affd6cc1665dddb Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 27 Jan 2019 21:41:21 +0100 Subject: [PATCH] Initial draft --- .gitignore | 2 + CHANGELOG.md | 5 +++ LICENSE | 30 +++++++++++++++ README.md | 3 ++ Setup.hs | 2 + hablo.cabal | 39 ++++++++++++++++++++ src/Arguments.hs | 72 ++++++++++++++++++++++++++++++++++++ src/Blog.hs | 72 ++++++++++++++++++++++++++++++++++++ src/Dom.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++++ src/JSON.hs | 17 +++++++++ src/Main.hs | 17 +++++++++ 11 files changed, 354 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 hablo.cabal create mode 100644 src/Arguments.hs create mode 100644 src/Blog.hs create mode 100644 src/Dom.hs create mode 100644 src/JSON.hs create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..bf5b663 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/dist-newstyle/* +.ghc.environment.* diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..badefea --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hablo + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..42f34d0 --- /dev/null +++ b/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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..d191861 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hablo.cabal b/hablo.cabal new file mode 100644 index 0000000..a70524c --- /dev/null +++ b/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 diff --git a/src/Arguments.hs b/src/Arguments.hs new file mode 100644 index 0000000..93923c2 --- /dev/null +++ b/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 + } diff --git a/src/Blog.hs b/src/Blog.hs new file mode 100644 index 0000000..2dfa79b --- /dev/null +++ b/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 } diff --git a/src/Dom.hs b/src/Dom.hs new file mode 100644 index 0000000..3ef32ce --- /dev/null +++ b/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) diff --git a/src/JSON.hs b/src/JSON.hs new file mode 100644 index 0000000..6aaf7b3 --- /dev/null +++ b/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 []) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..0ef8693 --- /dev/null +++ b/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 + )