Implement correct behaviour for default and custom articles and pages as outlined by the previous unit tests
This commit is contained in:
parent
804d3aa644
commit
f9465d1aa5
4 changed files with 48 additions and 38 deletions
10
src/Blog.hs
10
src/Blog.hs
|
@ -34,14 +34,14 @@ import qualified Data.Map as Map (empty, fromList)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import qualified Data.Set as Set (empty, null, singleton, union)
|
import qualified Data.Set as Set (empty, null, singleton, union)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Files (File(..), absolute)
|
import Files (File(..), filePath)
|
||||||
import qualified Files (find)
|
import qualified Files (find)
|
||||||
import Markdown (getKey)
|
import Markdown (getKey)
|
||||||
import Page (Page)
|
import Page (Page)
|
||||||
import qualified Page (at)
|
import qualified Page (at)
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import System.Directory (doesFileExist, withCurrentDirectory)
|
import Pretty (assertRight, onRight)
|
||||||
import System.Exit (die)
|
import System.Directory (doesFileExist, makeAbsolute, withCurrentDirectory)
|
||||||
import System.FilePath ((</>), dropTrailingPathSeparator, takeExtension, takeFileName)
|
import System.FilePath ((</>), dropTrailingPathSeparator, takeExtension, takeFileName)
|
||||||
import Text.Parsec (ParseError)
|
import Text.Parsec (ParseError)
|
||||||
|
|
||||||
|
@ -114,9 +114,9 @@ build arguments = do
|
||||||
let hasRSS = maybe False (\_-> True) $ rss urls
|
let hasRSS = maybe False (\_-> True) $ rss urls
|
||||||
wording <- Wording.build arguments
|
wording <- Wording.build arguments
|
||||||
templates <- Template.build wording
|
templates <- Template.build wording
|
||||||
root <- Files.absolute . Dir $ Arguments.sourceDir arguments
|
root <- onRight makeAbsolute =<< filePath (Dir $ Arguments.sourceDir arguments)
|
||||||
withCurrentDirectory root $ do
|
withCurrentDirectory root $ do
|
||||||
path <- either die return =<< Path.build root arguments
|
path <- assertRight =<< Path.build root arguments
|
||||||
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
|
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
|
||||||
$ Arguments.name arguments
|
$ Arguments.name arguments
|
||||||
skin <- Skin.build name arguments
|
skin <- Skin.build name arguments
|
||||||
|
|
|
@ -8,9 +8,11 @@ module Blog.Path (
|
||||||
|
|
||||||
import Arguments (Arguments)
|
import Arguments (Arguments)
|
||||||
import qualified Arguments as 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.Aeson (ToJSON(..), (.=), pairs)
|
||||||
import Data.Monoid ((<>))
|
import Data.Monoid ((<>))
|
||||||
import Files (File(..), filePath, filePathMaybe)
|
import Files (File(..), filePath)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
data Path = Path {
|
data Path = Path {
|
||||||
|
@ -26,18 +28,22 @@ instance ToJSON Path where
|
||||||
<> "pagesPath" .= pagesPath
|
<> "pagesPath" .= pagesPath
|
||||||
)
|
)
|
||||||
|
|
||||||
getMarkdownPath :: FilePath -> Maybe FilePath -> IO (Maybe FilePath)
|
checkFor :: (FilePath -> File) -> FilePath -> ExceptT String IO (Maybe FilePath)
|
||||||
getMarkdownPath defaultPath Nothing = filePathMaybe (Dir defaultPath)
|
checkFor fileOrDir = ExceptT . fmap (Just <$>) . filePath . fileOrDir
|
||||||
getMarkdownPath _ (Just path) = Just <$> filePath (Dir path)
|
|
||||||
|
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 :: FilePath -> Arguments -> IO (Either String Path)
|
||||||
build root arguments = do
|
build root arguments = runExceptT . join $ pack
|
||||||
articlesPath <- getMarkdownPath "articles" $ Arguments.articlesPath arguments
|
<$> getMarkdownPath "articles" (Arguments.articlesPath arguments)
|
||||||
pagesPath <- getMarkdownPath "pages" $ Arguments.pagesPath arguments
|
<*> getMarkdownPath "pages" (Arguments.pagesPath arguments)
|
||||||
remarkableConfig <- mapM (filePath . File) $ Arguments.remarkableConfig arguments
|
<*> maybe ignore (checkFor File) (Arguments.remarkableConfig arguments)
|
||||||
checkForContent articlesPath pagesPath remarkableConfig
|
|
||||||
where
|
where
|
||||||
checkForContent Nothing Nothing _ = return $
|
pack Nothing Nothing _ =
|
||||||
Left "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep"
|
throwError "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep"
|
||||||
checkForContent articlesPath pagesPath remarkableConfig =
|
pack articlesPath pagesPath remarkableConfig =
|
||||||
return . Right $ Path {articlesPath, pagesPath, remarkableConfig, root}
|
return $ Path {articlesPath, pagesPath, remarkableConfig, root}
|
||||||
|
ignore = return Nothing
|
||||||
|
|
32
src/Files.hs
32
src/Files.hs
|
@ -1,38 +1,32 @@
|
||||||
module Files (
|
module Files (
|
||||||
File(..)
|
File(..)
|
||||||
, absolute
|
|
||||||
, absoluteLink
|
, absoluteLink
|
||||||
, filePath
|
, filePath
|
||||||
, filePathMaybe
|
|
||||||
, find
|
, find
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import System.Exit (die)
|
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
|
||||||
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)
|
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
|
|
||||||
data File = File FilePath | Dir FilePath
|
data File = File FilePath | Dir FilePath
|
||||||
|
|
||||||
absolute :: File -> IO (FilePath)
|
|
||||||
absolute file = filePath file >>= makeAbsolute
|
|
||||||
|
|
||||||
absoluteLink :: FilePath -> FilePath
|
absoluteLink :: FilePath -> FilePath
|
||||||
absoluteLink ('.':path) = path
|
absoluteLink ('.':path) = path
|
||||||
absoluteLink path = "/" </> path
|
absoluteLink path = "/" </> path
|
||||||
|
|
||||||
filePathMaybe :: File -> IO (Maybe FilePath)
|
filePath :: File -> IO (Either String FilePath)
|
||||||
filePathMaybe = filePathAux
|
filePath = filePathAux
|
||||||
where
|
where
|
||||||
filePathAux (File path) = ifToMaybe path <$> doesFileExist path
|
filePathAux (File path) = ifIO doesFileExist path Right (notExist . File)
|
||||||
filePathAux (Dir path) = ifToMaybe path <$> doesDirectoryExist path
|
filePathAux (Dir path) = ifIO doesDirectoryExist path Right (notExist . Dir)
|
||||||
ifToMaybe path bool = if bool then return path else Nothing
|
ifIO predicate value whenTrue whenFalse = do
|
||||||
|
result <- predicate value
|
||||||
filePath :: File -> IO FilePath
|
return $ if result then whenTrue value else whenFalse value
|
||||||
filePath file = filePathMaybe file >>= maybe (die $ notExist file) return
|
notExist (File path) = Left $ path ++ ": no such file"
|
||||||
where
|
notExist (Dir path) = Left $ path ++ ": no such directory"
|
||||||
notExist (File path) = path ++ ": no such file"
|
|
||||||
notExist (Dir path) = path ++ ": no such directory"
|
|
||||||
|
|
||||||
find :: FilePath -> IO [FilePath]
|
find :: FilePath -> IO [FilePath]
|
||||||
find path =
|
find path =
|
||||||
filePathMaybe (Dir path) >>= maybe (return []) (fmap ((path </>) <$>) . listDirectory)
|
filePath (Dir path) >>= emptyIfMissing (fmap ((path </>) <$>) . listDirectory)
|
||||||
|
where
|
||||||
|
emptyIfMissing = either (\_ -> return [])
|
||||||
|
|
|
@ -1,6 +1,16 @@
|
||||||
module Pretty (
|
module Pretty (
|
||||||
(.$)
|
(.$)
|
||||||
|
, assertRight
|
||||||
|
, onRight
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import System.Exit (die)
|
||||||
|
|
||||||
(.$) :: (a -> b) -> (b -> c) -> (a -> c)
|
(.$) :: (a -> b) -> (b -> c) -> (a -> c)
|
||||||
(.$) f g = g . f
|
(.$) 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
|
||||||
|
|
Loading…
Reference in a new issue