73 lines
2.3 KiB
Haskell
73 lines
2.3 KiB
Haskell
{-# 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 }
|