diff --git a/src/Arguments.hs b/src/Arguments.hs index cbfe84d..3b6b447 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -9,9 +9,7 @@ import Control.Applicative ((<|>), (<**>), optional) import Options.Applicative (Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc, header, help, helper, info, long, metavar, short, str, value) import qualified Options.Applicative as Optparse (option) import qualified Paths_hablo as Hablo (version) -import System.Directory (doesDirectoryExist, doesFileExist, makeAbsolute) -import System.Exit (die) -import System.FilePath ((), dropTrailingPathSeparator, isValid) +import System.FilePath (dropTrailingPathSeparator, isValid) data Arguments = BlogConfig { sourceDir :: FilePath @@ -89,37 +87,9 @@ filePath = eitherReader $ \path -> then Right $ dropTrailingPathSeparator path else Left "This string doesn't represent a valid path" -ifNotDie :: (a -> IO Bool) -> (a -> String) -> a -> IO () -ifNotDie check messageBuilder input = do - bool <- check input - if bool - then return () - else die $ messageBuilder input - -checkAndMakeAbsolute :: Arguments -> IO Arguments -checkAndMakeAbsolute Version = return Version -checkAndMakeAbsolute aBlogConfig = do - doesDirectoryExist `ifNotDie` noSuchDirectory $ sourceDir aBlogConfig - doesDirectoryExist `ifNotDie` noSuchDirectory $ - sourceDir aBlogConfig articlesPath aBlogConfig - absoluteSourceDir <- makeAbsolute $ sourceDir aBlogConfig - mapM_ (doesFileExist `ifNotDie` noSuchFile) $ bannerPath aBlogConfig - absoluteBannerPath <- mapM makeAbsolute $ bannerPath aBlogConfig - mapM_ (doesFileExist `ifNotDie` noSuchFile) $ headPath aBlogConfig - absoluteHeadPath <- mapM makeAbsolute $ headPath aBlogConfig - return $ aBlogConfig { - sourceDir = absoluteSourceDir - , bannerPath = absoluteBannerPath - , headPath = absoluteHeadPath - } - where - noSuchDirectory = (++ ": no such directory") - noSuchFile = (++ ": no such file") - get :: IO Arguments get = do - checkAndMakeAbsolute =<< (execParser $ - info - (arguments <**> helper) - (fullDesc <> header ("Hablo v" ++ showVersion Hablo.version)) - ) + execParser $ + info + (arguments <**> helper) + (fullDesc <> header ("Hablo v" ++ showVersion Hablo.version)) diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index 37c083b..0a5ead9 100644 --- a/src/ArticlesList.hs +++ b/src/ArticlesList.hs @@ -13,6 +13,7 @@ import Control.Monad.Reader (MonadReader) import Data.Text (Text, pack) import Data.Text.Lazy (toStrict) import Data.Text.Template (render) +import Files (absoluteLink) import Pretty ((.$)) import System.FilePath.Posix (()) @@ -23,12 +24,8 @@ data ArticlesList = ArticlesList { } otherUrl :: ArticlesList -> String -otherUrl (ArticlesList {full, tagged}) = - if full - then url tagged - else url tagged "all.html" - where - url = maybe "/" ("/" ) +otherUrl (ArticlesList {full, tagged}) = absoluteLink $ + (if full then id else ( "all.html")) $ maybe "" id tagged pageTitle :: (MonadReader Blog m) => ArticlesList -> m Text pageTitle (ArticlesList {full, tagged}) = do diff --git a/src/Blog.hs b/src/Blog.hs index 8eb8de4..02fefc6 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -67,15 +67,19 @@ tagged collection path = do 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 +discover :: Path -> IO (Collection, Map String (Set String)) +discover path = withCurrentDirectory (root path) $ do 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 + return (articles, tags) + +build :: Arguments -> IO Blog +build arguments = do + path <- Path.build arguments + let name = maybe (takeFileName . dropTrailingPathSeparator $ root path) id $ Arguments.name arguments + skin <- Skin.build name arguments + wording <- Wording.build arguments + (articles, tags) <- discover path + return $ Blog {articles, name, path, skin, tags, wording} diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs index 703d9d6..396f5e9 100644 --- a/src/Blog/Path.hs +++ b/src/Blog/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} module Blog.Path ( Path(..) , build @@ -5,6 +6,7 @@ module Blog.Path ( import Arguments (Arguments) import qualified Arguments as Arguments (Arguments(..)) +import Files (File(..), absolute, filePath) data Path = Path { articlesPath :: FilePath @@ -13,10 +15,11 @@ data Path = Path { , root :: FilePath } -build :: Arguments -> Path -build arguments = Path { - articlesPath = Arguments.articlesPath arguments - , commentsAt = Arguments.commentsAt arguments - , pagesPath = Arguments.pagesPath arguments - , root = Arguments.sourceDir arguments - } +build :: Arguments -> IO Path +build arguments = do + articlesPath <- filePath . Dir $ Arguments.articlesPath arguments + pagesPath <- mapM (filePath . Dir) $ Arguments.pagesPath arguments + root <- absolute . Dir $ Arguments.sourceDir arguments + return $ Path { + articlesPath, commentsAt = Arguments.commentsAt arguments, pagesPath, root + } diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index fff5449..a5cf2f5 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -8,6 +8,7 @@ import Arguments (Arguments) import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount) import Control.Monad (filterM) import Data.Maybe (listToMaybe) +import Files (absoluteLink) import Prelude hiding (head) import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) @@ -21,14 +22,10 @@ data Skin = Skin { , previewLinesCount :: Int } -absolute :: FilePath -> FilePath -absolute ('.':path) = path -absolute path = "/" path - findImage :: String -> Maybe FilePath -> IO (Maybe FilePath) -findImage _ (Just path) = return . Just $ absolute path +findImage _ (Just path) = return . Just $ absoluteLink path findImage name Nothing = - fmap absolute . listToMaybe <$> filterM doesFileExist pathsToCheck + fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck where directories = [".", "image", "images", "pictures", "skin", "static"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] diff --git a/src/Dom.hs b/src/Dom.hs index 6967972..4fae2f4 100644 --- a/src/Dom.hs +++ b/src/Dom.hs @@ -14,6 +14,7 @@ import Control.Monad.Reader (ReaderT) import qualified Data.Map as Map (keys, lookup) import Data.Monoid ((<>)) import Data.Text (Text, pack, empty) +import Files (absoluteLink) import Lucid import Lucid.Base (makeAttribute) import Prelude hiding (head, lookup) @@ -55,7 +56,7 @@ instance Page ArticlesList where article :: Bool -> Article -> HtmlGenerator () article raw (Article {key, body, title}) = do - url <- ("/" ) . ( key <.> extension) <$> (Blog.get $path.$articlesPath) + url <- absoluteLink . ( key <.> extension) <$> (Blog.get $path.$articlesPath) article_ (do header_ (do aElem [href_ . pack $ url] . h1_ $ toHtml title @@ -79,7 +80,7 @@ navigationA :: Term arg result => arg -> result navigationA = "a" `termWith` [class_ "navigation"] tag :: String -> HtmlGenerator () -tag tagName = li_ (navigationA [href_ $ pack ("/" tagName)] $ toHtml tagName) +tag tagName = li_ (navigationA [href_ . pack $ absoluteLink tagName] $ toHtml tagName) defaultBanner :: HtmlGenerator () defaultBanner = do diff --git a/src/Files.hs b/src/Files.hs index e12f464..d82ea89 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,9 +1,34 @@ module Files ( - find + File(..) + , absolute + , absoluteLink + , filePath + , find ) where +import System.Exit (die) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute) import System.FilePath (()) -import System.Directory (listDirectory) + +data File = File FilePath | Dir FilePath + +absolute :: File -> IO (FilePath) +absolute file = filePath file >>= makeAbsolute + +absoluteLink :: FilePath -> FilePath +absoluteLink ('.':path) = path +absoluteLink path = "/" path + +filePath :: File -> IO FilePath +filePath file = do + let (thePath, test, errorMessage) = + case file of + File path -> (path, doesFileExist, (++ ": no such file")) + Dir path -> (path, doesDirectoryExist, (++ ": no such directory")) + bool <- test thePath + if bool + then return thePath + else die $ errorMessage thePath find :: FilePath -> IO [FilePath] find path =