From f9465d1aa5f3ebc0a377eab0e2bbddede70b7643 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 25 Oct 2020 22:20:57 +0100 Subject: [PATCH] Implement correct behaviour for default and custom articles and pages as outlined by the previous unit tests --- src/Blog.hs | 10 +++++----- src/Blog/Path.hs | 32 +++++++++++++++++++------------- src/Files.hs | 32 +++++++++++++------------------- src/Pretty.hs | 12 +++++++++++- 4 files changed, 48 insertions(+), 38 deletions(-) diff --git a/src/Blog.hs b/src/Blog.hs index 246181b..524514e 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -34,14 +34,14 @@ import qualified Data.Map as Map (empty, fromList) import Data.Set (Set) import qualified Data.Set as Set (empty, null, singleton, union) import Data.Text (Text) -import Files (File(..), absolute) +import Files (File(..), filePath) import qualified Files (find) import Markdown (getKey) import Page (Page) import qualified Page (at) import Prelude hiding (lookup) -import System.Directory (doesFileExist, withCurrentDirectory) -import System.Exit (die) +import Pretty (assertRight, onRight) +import System.Directory (doesFileExist, makeAbsolute, withCurrentDirectory) import System.FilePath ((), dropTrailingPathSeparator, takeExtension, takeFileName) import Text.Parsec (ParseError) @@ -114,9 +114,9 @@ build arguments = do let hasRSS = maybe False (\_-> True) $ rss urls wording <- Wording.build arguments templates <- Template.build wording - root <- Files.absolute . Dir $ Arguments.sourceDir arguments + root <- onRight makeAbsolute =<< filePath (Dir $ Arguments.sourceDir arguments) withCurrentDirectory root $ do - path <- either die return =<< Path.build root arguments + path <- assertRight =<< Path.build root arguments let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ Arguments.name arguments skin <- Skin.build name arguments diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs index aa60a2f..a0f8fcd 100644 --- a/src/Blog/Path.hs +++ b/src/Blog/Path.hs @@ -8,9 +8,11 @@ module Blog.Path ( import Arguments (Arguments) import qualified Arguments as Arguments (Arguments(..)) +import Control.Monad (join) +import Control.Monad.Except (MonadError(..), ExceptT(..), runExceptT) import Data.Aeson (ToJSON(..), (.=), pairs) import Data.Monoid ((<>)) -import Files (File(..), filePath, filePathMaybe) +import Files (File(..), filePath) import GHC.Generics (Generic) data Path = Path { @@ -26,18 +28,22 @@ instance ToJSON Path where <> "pagesPath" .= pagesPath ) -getMarkdownPath :: FilePath -> Maybe FilePath -> IO (Maybe FilePath) -getMarkdownPath defaultPath Nothing = filePathMaybe (Dir defaultPath) -getMarkdownPath _ (Just path) = Just <$> filePath (Dir path) +checkFor :: (FilePath -> File) -> FilePath -> ExceptT String IO (Maybe FilePath) +checkFor fileOrDir = ExceptT . fmap (Just <$>) . filePath . fileOrDir + +getMarkdownPath :: FilePath -> Maybe FilePath -> ExceptT String IO (Maybe FilePath) +getMarkdownPath defaultPath Nothing = + ExceptT . (Right . either (\_ -> Nothing) Just <$>) . filePath $ Dir defaultPath +getMarkdownPath _ (Just customPath) = checkFor Dir customPath build :: FilePath -> Arguments -> IO (Either String Path) -build root arguments = do - articlesPath <- getMarkdownPath "articles" $ Arguments.articlesPath arguments - pagesPath <- getMarkdownPath "pages" $ Arguments.pagesPath arguments - remarkableConfig <- mapM (filePath . File) $ Arguments.remarkableConfig arguments - checkForContent articlesPath pagesPath remarkableConfig +build root arguments = runExceptT . join $ pack + <$> getMarkdownPath "articles" (Arguments.articlesPath arguments) + <*> getMarkdownPath "pages" (Arguments.pagesPath arguments) + <*> maybe ignore (checkFor File) (Arguments.remarkableConfig arguments) where - checkForContent Nothing Nothing _ = return $ - Left "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep" - checkForContent articlesPath pagesPath remarkableConfig = - return . Right $ Path {articlesPath, pagesPath, remarkableConfig, root} + pack Nothing Nothing _ = + throwError "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep" + pack articlesPath pagesPath remarkableConfig = + return $ Path {articlesPath, pagesPath, remarkableConfig, root} + ignore = return Nothing diff --git a/src/Files.hs b/src/Files.hs index 31bba4e..b6bec82 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,38 +1,32 @@ module Files ( File(..) - , absolute , absoluteLink , filePath - , filePathMaybe , find ) where -import System.Exit (die) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) data File = File FilePath | Dir FilePath -absolute :: File -> IO (FilePath) -absolute file = filePath file >>= makeAbsolute - absoluteLink :: FilePath -> FilePath absoluteLink ('.':path) = path absoluteLink path = "/" path -filePathMaybe :: File -> IO (Maybe FilePath) -filePathMaybe = filePathAux +filePath :: File -> IO (Either String FilePath) +filePath = filePathAux where - filePathAux (File path) = ifToMaybe path <$> doesFileExist path - filePathAux (Dir path) = ifToMaybe path <$> doesDirectoryExist path - ifToMaybe path bool = if bool then return path else Nothing - -filePath :: File -> IO FilePath -filePath file = filePathMaybe file >>= maybe (die $ notExist file) return - where - notExist (File path) = path ++ ": no such file" - notExist (Dir path) = path ++ ": no such directory" + filePathAux (File path) = ifIO doesFileExist path Right (notExist . File) + filePathAux (Dir path) = ifIO doesDirectoryExist path Right (notExist . Dir) + ifIO predicate value whenTrue whenFalse = do + result <- predicate value + return $ if result then whenTrue value else whenFalse value + notExist (File path) = Left $ path ++ ": no such file" + notExist (Dir path) = Left $ path ++ ": no such directory" find :: FilePath -> IO [FilePath] find path = - filePathMaybe (Dir path) >>= maybe (return []) (fmap ((path ) <$>) . listDirectory) + filePath (Dir path) >>= emptyIfMissing (fmap ((path ) <$>) . listDirectory) + where + emptyIfMissing = either (\_ -> return []) diff --git a/src/Pretty.hs b/src/Pretty.hs index f014ccf..584544a 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -1,6 +1,16 @@ module Pretty ( - (.$) + (.$) + , assertRight + , onRight ) where +import System.Exit (die) + (.$) :: (a -> b) -> (b -> c) -> (a -> c) (.$) f g = g . f + +onRight :: (a -> IO b) -> Either String a -> IO b +onRight = either die + +assertRight :: Either String a -> IO a +assertRight = onRight return