80 lines
2.4 KiB
Haskell
80 lines
2.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Blog (
|
|
Blog(..)
|
|
, Skin(..)
|
|
, build
|
|
, get
|
|
) where
|
|
|
|
import Arguments (Arguments(sourceDir))
|
|
import qualified Arguments (name)
|
|
import Article (Article)
|
|
import qualified Article (at)
|
|
import Blog.Skin (Skin(..))
|
|
import qualified Blog.Skin as Skin (build)
|
|
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
|
|
, root :: FilePath
|
|
, skin :: Skin
|
|
, tags :: Map String (Set FileID)
|
|
}
|
|
|
|
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 $ Arguments.name arguments
|
|
skin <- Skin.build name arguments
|
|
articles <- findArticles (previewLinesCount skin) articlesPath
|
|
tags <- Map.fromList . filter (not . Set.null . snd)
|
|
<$> (Files.find (articlesPath </> "tags") >>= mapM (articles `tagged`))
|
|
return $ Blog {
|
|
articles
|
|
, name
|
|
, root
|
|
, skin
|
|
, tags
|
|
}
|
|
where
|
|
(root, articlesPath) = splitFileName $ sourceDir arguments
|