76 lines
2.5 KiB
Haskell
76 lines
2.5 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Blog (
|
|
Article(..)
|
|
, Blog(..)
|
|
, get
|
|
) where
|
|
|
|
import Arguments (Arguments(..))
|
|
import Control.Monad ((>=>), filterM, forM)
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
|
import Data.Map (Map)
|
|
import Data.Text (Text, pack)
|
|
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, withCurrentDirectory)
|
|
import System.FilePath ((</>), dropTrailingPathSeparator, splitFileName, takeExtension, takeFileName)
|
|
import System.Posix.Types (FileID)
|
|
import System.Posix.Files (FileStatus, getFileStatus, fileID)
|
|
|
|
data Article = Article {
|
|
urlPath :: Text
|
|
, fileStatus :: FileStatus
|
|
}
|
|
|
|
type Collection = Map FileID Article
|
|
|
|
data Blog = Blog {
|
|
articles :: Collection
|
|
, name :: String
|
|
, previewCount :: Int
|
|
, root :: FilePath
|
|
, 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 { urlPath = pack $ "/" </> 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 :: Arguments -> IO Blog
|
|
get (Arguments {sourceDir, blogName, previewCountArg}) = withCurrentDirectory root $ do
|
|
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName
|
|
articles <- findArticles articlesPath
|
|
tags <- Map.fromList . filter (not . Set.null . snd)
|
|
<$> (find (articlesPath </> "tags") >>= mapM (articles `tagged`))
|
|
return $ Blog { articles , name, previewCount = previewCountArg, root, tags }
|
|
where
|
|
(root, articlesPath) = splitFileName sourceDir
|