hablo/src/Blog.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Blog (
      Blog(..)
    , build
    , get
  ) where

import Arguments (Arguments(bannerPath, blogName, headPath, sourceDir))
import qualified Arguments (previewArticlesCount, previewLinesCount)
import Article (Article)
import qualified Article (at)
import Control.Monad ((>=>), filterM, forM)
import Control.Monad.Reader (MonadReader, ask)
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 qualified Files (find)
import System.Directory (doesFileExist, withCurrentDirectory)
import System.FilePath ((</>), dropTrailingPathSeparator, splitFileName, takeExtension, takeFileName)
import System.Posix.Types (FileID)
import System.Posix.Files (getFileStatus, fileID)

type Collection = Map FileID Article

data Blog = Blog {
      articles :: Collection
    , name :: String
    , previewArticlesCount :: Int
    , previewLinesCount :: Int
    , root :: FilePath
    , tags :: Map String (Set FileID)
    , customBanner :: Maybe String
    , customHead :: Maybe String
  }

get :: MonadReader Blog m => (Blog -> a) -> m a
get = (<$> ask)

findArticles :: Int -> FilePath -> IO (Map FileID Article)
findArticles linesCount =
  Files.find
  >=> filterM isMarkDownFile
  >=> mapM (Article.at linesCount)
  >=> return . Map.fromList
  where
    isMarkDownFile path = do
      let correctExtension = takeExtension path == ".md"
      (correctExtension &&) <$> doesFileExist path

tagged :: Collection -> FilePath -> IO (String, Set FileID)
tagged collection path = do
  links <- Files.find path
  fileIDs <- forM links $ \link -> do
    fileExists <- doesFileExist link
    if fileExists
      then do
        inode <- fileID <$> 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)

build :: Arguments -> IO Blog
build arguments = withCurrentDirectory root $ do
  let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments
  let previewLinesCount = Arguments.previewLinesCount arguments
  articles <- findArticles previewLinesCount articlesPath
  tags <- Map.fromList . filter (not . Set.null . snd)
    <$> (Files.find (articlesPath </> "tags") >>= mapM (articles `tagged`))
  customBanner <- mapM readFile $ bannerPath arguments
  customHead <- mapM readFile $ headPath arguments
  return $ Blog {
        articles
      , name
      , previewArticlesCount = Arguments.previewArticlesCount arguments
      , previewLinesCount
      , root
      , tags
      , customBanner
      , customHead
    }
  where
    (root, articlesPath) = splitFileName $ sourceDir arguments