hablo/src/Blog.hs

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

import Arguments (Arguments)
import qualified Arguments (name)
import Article (Article)
import qualified Article (at, getKey)
import Blog.Path (Path(..))
import qualified Blog.Path as Path (build)
import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build)
import Blog.Wording (Wording(..))
import qualified Blog.Wording as Wording (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)
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, takeExtension, takeFileName)

type Collection = Map String Article

data Blog = Blog {
      articles :: Collection
    , name :: String
    , path :: Path
    , skin :: Skin
    , tags :: Map String (Set String)
    , wording :: Wording
  }

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

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

tagged :: Collection -> FilePath -> IO (String, Set String)
tagged collection path = do
  links <- Files.find path
  keys <- forM links $ \link -> do
    fileExists <- doesFileExist link
    return $ if fileExists
      then let articleKey = Article.getKey link in
        maybe Set.empty (\_ -> Set.singleton articleKey) (collection !? articleKey)
      else Set.empty
  return (takeFileName path, foldl Set.union Set.empty keys)

build :: Arguments -> IO Blog
build arguments = withCurrentDirectory (root path) $ do
  skin <- Skin.build name arguments
  wording <- Wording.build arguments
  articles <- findArticles $ articlesPath path
  tags <- Map.fromList . filter (not . Set.null . snd)
    <$> (Files.find (articlesPath path </> "tags") >>= mapM (articles `tagged`))
  return $ Blog {articles, name, path, skin, tags, wording}
  where
    path = Path.build arguments
    name = maybe (takeFileName . dropTrailingPathSeparator $ root path) id
            $ Arguments.name arguments