diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2020 Lucas Escot + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/achille.cabal b/achille.cabal new file mode 100644 --- /dev/null +++ b/achille.cabal @@ -0,0 +1,80 @@ +name: achille +version: 0.0.0 +synopsis: A library for building static site generators +category: Web +description: + achille is a library for building incremental static site generators. + For more information, see here: . + +bug-reports: https://github.com/flupe/achille/issues +homepage: https://acatalepsie.fr/projects/achille +author: Lucas Escot +maintainer: Lucas Escot +license: MIT +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple +tested-with: GHC == 8.8.4 + +source-repository head + type: git + location: git://github.com/flupe/achille.git + +flag pandoc + description: Enable Pandoc and Front Matter header support + default: True + +library + default-language: Haskell2010 + hs-source-dirs: src + default-extensions: BlockArguments + , LambdaCase + , TupleSections + , CPP + exposed-modules: Achille + , Achille.Config + , Achille.Writable + , Achille.Timestamped + , Achille.Internal + , Achille.Internal.IO + , Achille.Recipe + , Achille.Task + build-depends: base >= 4.11 && < 5 + , process >= 1.6.9 && < 1.7 + , filepath >= 1.4.2 && < 1.5 + , directory >= 1.3.6 && < 1.4 + , Glob >= 0.10.1 && < 0.11 + , binary >= 0.8.7 && < 0.9 + , bytestring >= 0.10.10 && < 0.11 + , text >= 1.2.4 && < 1.3 + , time >= 1.9.3 && < 1.10 + , data-default >= 0.7.1 && < 0.8 + , optparse-applicative >= 0.15.1 && < 0.16 + , binary-instances >= 1.0.0 && < 1.1 + + + if flag(pandoc) + exposed-modules: Achille.Recipe.Pandoc + build-depends: pandoc >= 2.9.2 && < 2.10 + , pandoc-types >= 1.20 && < 1.21 + , frontmatter >= 0.1.0 && < 0.2 + , aeson >= 1.4.7 && < 1.5 + +test-suite test-achille + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: FakeIO + hs-source-dirs: tests + build-depends: base >= 4.11 && < 5 + , directory + , text + , containers + , filepath + , bytestring + , Glob + , tasty + , tasty-hunit + , time + , mtl + , achille diff --git a/src/Achille.hs b/src/Achille.hs new file mode 100644 --- /dev/null +++ b/src/Achille.hs @@ -0,0 +1,59 @@ +-- | Top-level module for achille, providing the CLI and task runner. +module Achille + ( module Achille.Config + , module Achille.Timestamped + , module Achille.Recipe + , module Achille.Task + , AchilleCommand + , achilleCLI + , achille + , achilleWith + ) where + + +import Control.Monad (void, mapM_) +import Control.Monad.IO.Class (MonadIO) +import System.Directory (removePathForcibly) +import System.FilePath.Glob (compile) +import Options.Applicative + +import qualified System.Process as Process + +import Achille.Config +import Achille.Timestamped +import Achille.Recipe +import Achille.Task + + +-- | CLI commands. +data AchilleCommand + = Build [String] -- ^ Build the site once + | Deploy -- ^ Deploy to the server + | Clean -- ^ Delete all artefacts + deriving (Eq, Show) + + +-- | CLI parser. +achilleCLI :: Parser AchilleCommand +achilleCLI = subparser $ + command "build" (info (Build <$> many (argument str (metavar "FILES"))) (progDesc "Build the site once" )) + <> command "deploy" (info (pure Deploy) (progDesc "Server go brrr" )) + <> command "clean" (info (pure Clean) (progDesc "Delete all artefacts")) + + +-- | Main entrypoint for achille. Provides a CLI for running a task. +achille :: Task IO a -> IO () +achille = achilleWith def + + +-- | CLI for running a task using given options. +achilleWith :: Config -> Task IO a -> IO () +achilleWith config task = customExecParser p opts >>= \case + Deploy -> mapM_ Process.callCommand (deployCmd config) + Clean -> removePathForcibly (outputDir config) + >> removePathForcibly (cacheFile config) + Build paths -> void $ runTask (map compile paths) config task + where + opts = info (achilleCLI <**> helper) $ fullDesc <> header desc + p = prefs showHelpOnEmpty + desc = "A static site generator for fun and profit" diff --git a/src/Achille/Config.hs b/src/Achille/Config.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Config.hs @@ -0,0 +1,30 @@ +-- | Exports a datatype for the top-level achille config. +module Achille.Config + ( Config (..) + , def + ) where + + +import System.FilePath (FilePath) +import Data.Default (Default, def) + + +-- | achille configuration datatype. +data Config = Config + { contentDir :: FilePath -- ^ Root of the source directory. + -- Defaults to @"content"@. + , outputDir :: FilePath -- ^ Root of the output directory. + -- Defaults to @"_site"@. + , cacheFile :: FilePath -- ^ Path where the cache is stored. + -- Defaults to @".cache"@. + , deployCmd :: Maybe String -- ^ Command to run for deploying the result. + } + + +instance Default Config where + def = Config + { contentDir = "content" + , outputDir = "_site" + , cacheFile = ".cache" + , deployCmd = Nothing + } diff --git a/src/Achille/Internal.hs b/src/Achille/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | Defines recipes, how they compose and evaluate. +module Achille.Internal + ( Cache + , emptyCache + , toCache + , fromCache + , fromContext + , MustRun(..) + , Context(..) + , Recipe(..) + , Task + , runRecipe + , nonCached + ) where + +import Prelude hiding (fail, liftIO) + +import Data.Binary (Binary, encode, decodeOrFail) +import Data.Maybe (fromMaybe) +import Data.Functor (void) +import Control.Monad (ap) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Fail (MonadFail, fail) +import Control.Applicative (liftA2) +import Data.Time.Clock (UTCTime) +import Data.ByteString.Lazy (ByteString, empty) +import Data.Bifunctor (first, second) +import System.FilePath.Glob (Pattern) + + +-- | A cache is a lazy bytestring. +type Cache = ByteString + + +-- | The empty cache. +emptyCache :: Cache +emptyCache = empty + +-- | Cache a value. +toCache :: Binary a => a -> Cache +toCache = encode + +-- | Retrieve a value from cache. +fromCache :: Binary a => Cache -> Maybe a +fromCache cache = + case decodeOrFail cache of + Left _ -> Nothing + Right (_, _, x) -> Just x + + +-- | Local rules for running a recipe +data MustRun = MustRunOne -- ^ The current recipe, and only this one, must run + | MustRunAll -- ^ All subsequent recipes must run + | NoMust -- ^ No obligation, the current recipe will be run as normal + deriving (Eq) + + +lowerMustRun :: MustRun -> MustRun +lowerMustRun MustRunAll = MustRunAll +lowerMustRun x = NoMust + +-- | Try to load a value from the cache, +-- while respecting the rule for running the recipe. +-- That is, if the rule must run, nothing will be returned. +-- We also lower the run rule in the returned context, if possible. +-- +-- The types are not explicit enough, should rewrite. +fromContext :: Binary a => Context b -> (Maybe a, Context b) +fromContext c = + let r = mustRun c in + if r /= NoMust then (Nothing, c {mustRun = lowerMustRun r}) + else (fromCache (cache c), c) + + + +-- | Description of a computation producing a value b given some input a. +newtype Recipe m a b = Recipe (Context a -> m (b, Cache)) + + +-- | Context in which a recipe is being executed. +data Context a = Context + { inputDir :: FilePath -- ^ Input root directory + , outputDir :: FilePath -- ^ Output root directory + , currentDir :: FilePath -- ^ Current directory + , timestamp :: UTCTime -- ^ Timestamp of the last run + , forceFiles :: [Pattern] -- ^ Files marked as dirty + , mustRun :: MustRun -- ^ Whether the current task must run + , cache :: Cache -- ^ Local cache + , inputValue :: a -- ^ Input value + } deriving (Functor) + + +-- | A task is a recipe with no input +type Task m = Recipe m () + + +-- | Make a recipe out of a computation that is known not to be cached. +nonCached :: Functor m => (Context a -> m b) -> Recipe m a b +nonCached f = Recipe \c -> (, emptyCache) <$> f c {cache = emptyCache} + + +-- | Run a recipe with a given context. +runRecipe :: Recipe m a b -> Context a -> m (b, Cache) +runRecipe (Recipe r) = r + + +instance Functor m => Functor (Recipe m a) where + fmap f (Recipe r) = Recipe \c -> first f <$> r c + + +instance Monad m => Applicative (Recipe m a) where + pure = Recipe . const . pure . (, emptyCache) + + (<*>) = ap + + +splitCache :: Cache -> (Cache, Cache) +splitCache = fromMaybe (emptyCache, emptyCache) . fromCache + + +instance Monad m => Monad (Recipe m a) where + Recipe r >>= f = Recipe \c -> do + let (cr, cf) = splitCache (cache c) + (x, cr') <- r c {cache = cr} + (y, cf') <- runRecipe (f x) c {cache = cf} + pure (y, toCache (cr', cf')) + + -- parallelism for free? + Recipe r >> Recipe s = Recipe \c -> do + let (cr, cs) = splitCache (cache c) + (_, cr') <- r c {cache = cr} + (y, cs') <- s c {cache = cs} + pure (y, toCache (cr', cs')) + + +instance MonadIO m => MonadIO (Recipe m a) where + liftIO = nonCached . const . liftIO + + +instance MonadFail m => MonadFail (Recipe m a) where + fail = Recipe . const . fail + + +instance (Monad m, Semigroup b) => Semigroup (Recipe m a b) where + x <> y = liftA2 (<>) x y + + +instance (Monad m, Monoid b) => Monoid (Recipe m a b) where + mempty = pure mempty diff --git a/src/Achille/Internal/IO.hs b/src/Achille/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Internal/IO.hs @@ -0,0 +1,81 @@ +-- | Defines an IO interface for core recipes +module Achille.Internal.IO + ( AchilleIO + , readFile + , readFileLazy + , copyFile + , writeFile + , writeFileLazy + , doesFileExist + , doesDirExist + , callCommand + , log + , glob + , getModificationTime + , fail + ) where + +import Prelude as Prelude hiding (log, readFile, writeFile) + +import Data.Text (Text) +import System.FilePath (FilePath) +import Data.Time.Clock (UTCTime) +import Control.Monad.Fail (MonadFail) + +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified System.FilePath.Glob as Glob +import qualified System.Process as Process +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS + + +-- | Interface for IO actions used by core recipes. +class (Monad m, MonadFail m) => AchilleIO m where + -- | Retrieve a file as a bytestring. + readFile :: FilePath -> m BS.ByteString + -- | Retrieve a file as a /lazy/ bytestring. + readFileLazy :: FilePath -> m LBS.ByteString + -- | Copy a file from one location to another. + copyFile :: FilePath -> FilePath -> m () + -- | Write a bytestring to a file. + writeFile :: FilePath -> BS.ByteString -> m () + -- | Write a /lazy/ bytestring to a file. + writeFileLazy :: FilePath -> LBS.ByteString -> m () + -- | Check whether a file exists. + doesFileExist :: FilePath -> m Bool + -- | Check whether a directory exists. + doesDirExist :: FilePath -> m Bool + -- | Run a shell command in a new process. + callCommand :: String -> m () + -- | Log a string to stdout. + log :: String -> m () + -- | Find all paths matching a given globpattern, relative to a given directory. + glob :: FilePath -- ^ Path of the root directory. + -> Glob.Pattern -> m [FilePath] + -- | Get modification time of a file. + getModificationTime :: FilePath -> m UTCTime + + +ensureDirExists :: FilePath -> IO () +ensureDirExists = + Directory.createDirectoryIfMissing True . FilePath.takeDirectory + + +instance AchilleIO IO where + readFile = BS.readFile + readFileLazy = LBS.readFile + copyFile from to = ensureDirExists to >> Directory.copyFile from to + writeFile to x = ensureDirExists to >> BS.writeFile to x + writeFileLazy to x = ensureDirExists to >> LBS.writeFile to x + doesFileExist = Directory.doesFileExist + doesDirExist = Directory.doesDirectoryExist + callCommand = Process.callCommand + log = Prelude.putStrLn + glob dir pattern = + Directory.withCurrentDirectory dir $ + Glob.globDir1 pattern "" + >>= mapM Directory.makeRelativeToCurrentDirectory + getModificationTime = Directory.getModificationTime diff --git a/src/Achille/Recipe.hs b/src/Achille/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Recipe.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Core recipes including reading files, saving them. +module Achille.Recipe + ( Recipe + , liftIO + , getInput + , getCurrentDir + , readText + , readBS + , saveFile + , saveFileAs + , copyFile + , copyFileAs + , copy + , write + , task + , debug + , callCommand + , runCommandWith + , toTimestamped + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Binary (Binary, encodeFile) +import Data.Functor (void) +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8) +import Data.ByteString (ByteString) +import System.FilePath (()) + +import Achille.Config +import Achille.Writable (Writable) +import Achille.Timestamped +import qualified Achille.Writable as Writable +import Achille.Internal as Internal +import Achille.Internal.IO (AchilleIO) +import qualified Achille.Internal.IO as AchilleIO + + +data Color = Red | Blue + +color :: Color -> String -> String +color c x = "\x1b[" <> start <> x <> "\x1b[0m" + where start = case c of + Red -> "31m" + Blue -> "34m" + +------------------------------------- +-- Recipe building blocks (uncached) +------------------------------------- + +-- | Recipe returning its input. +getInput :: Applicative m + => Recipe m a a +getInput = nonCached $ pure . inputValue + +-- | Recipe for retrieving the current directory +getCurrentDir :: Applicative m + => Recipe m a FilePath +getCurrentDir = nonCached (pure . Internal.currentDir) + +-- | Recipe retrieving the contents of the input file as text +readText :: AchilleIO m + => Recipe m FilePath Text +readText = nonCached \Context{..} -> + decodeUtf8 <$> AchilleIO.readFile (inputDir currentDir inputValue) + +-- | Recipe retrieving the contents of the input file as a bytestring. +readBS :: AchilleIO m => Recipe m FilePath ByteString +readBS = nonCached \Context{..} -> + AchilleIO.readFile (inputDir currentDir inputValue) + +-- | Recipe for saving a value to the location given as input. +-- Returns the input filepath as is. +saveFile :: (AchilleIO m, Writable m a) + => a -> Recipe m FilePath FilePath +saveFile = saveFileAs id + +-- | Recipe for saving a value to a file, using the path modifier applied to the input filepath. +-- Returns the path of the output file. +saveFileAs :: (AchilleIO m, Writable m a) + => (FilePath -> FilePath) -> a -> Recipe m FilePath FilePath +saveFileAs mod x = flip write x =<< mod <$> getInput + +-- | Recipe for copying an input file to the same location in the output dir. +copyFile :: AchilleIO m + => Recipe m FilePath FilePath +copyFile = copyFileAs id + +-- | Recipe for copying an input file to the output dir, using the path modifier. +copyFileAs :: AchilleIO m + => (FilePath -> FilePath) -> Recipe m FilePath FilePath +copyFileAs mod = getInput >>= \from -> copy from (mod from) + +-- | Recipe for copying a file to a given destination. +-- Returns the output filepath. +copy :: AchilleIO m + => FilePath -> FilePath -> Recipe m a FilePath +copy from to = nonCached \Context{..} -> do + AchilleIO.copyFile (inputDir currentDir from) + (outputDir currentDir to) + AchilleIO.log (color Blue $ (currentDir from) <> " → " <> (currentDir to)) + pure to + +-- | Recipe for writing to a an output file. +-- Returns the output filepath. +write :: (AchilleIO m, Writable m b) + => FilePath -> b -> Recipe m a FilePath +write to x = nonCached \Context{..} -> do + Writable.write (outputDir currentDir to) x + AchilleIO.log (color Blue $ "writing " <> (currentDir to)) + pure to + +-- | Make a recipe out of a task. The input will simply be discarded. +task :: Task m b -> Recipe m a b +task (Recipe r) = Recipe (r . void) + + + +------------------------------ +-- Lifted IO +------------------------------ + +-- | Recipe for printing a value to the console. +debug :: AchilleIO m + => Show b => b -> Recipe m a () +debug = nonCached . const . AchilleIO.log . show + +-- | Recipe for running a shell command in a new process. +callCommand :: AchilleIO m + => String -> Recipe m a () +callCommand = nonCached . const . AchilleIO.callCommand + +-- | Recipe for running a shell command in a new process. +-- The command is defined with an helper function which depends on an input filepath +-- and the same filepath with a modifier applied. +-- +-- Examples: +-- +-- > cp :: Recipe IO FilePath FilePath +-- > cp = runCommandWith id (\a b -> "cp " <> a <> " " <> b) +runCommandWith :: AchilleIO m + => (FilePath -> FilePath) + -> (FilePath -> FilePath -> String) + -> Recipe m FilePath FilePath +runCommandWith mod cmd = nonCached \Context{..} -> + let p' = mod inputValue + in AchilleIO.callCommand (cmd (inputDir currentDir inputValue) + (outputDir currentDir p')) + >> pure p' + +-- | Recipe that will retrieve the datetime contained in a filepath. +toTimestamped :: Monad m => FilePath -> Recipe m a (Timestamped FilePath) +toTimestamped = pure . timestamped diff --git a/src/Achille/Recipe/Pandoc.hs b/src/Achille/Recipe/Pandoc.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Recipe/Pandoc.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Defines convenience recipes for reading and writing documents with pandoc. +module Achille.Recipe.Pandoc + ( readPandoc + , readPandocWith + , readPandocMetadata + , readPandocMetadataWith + , renderPandoc + , renderPandocWith + , compilePandoc + , compilePandocWith + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Binary (Binary, encodeFile) +import Data.Functor (void) +import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8) +import System.Directory (copyFile, createDirectoryIfMissing, withCurrentDirectory) + +import System.FilePath +import Text.Pandoc hiding (nonCached) +import Data.Aeson.Types (FromJSON) +import Data.Frontmatter (parseYamlFrontmatter, IResult(..)) + +import qualified Data.Text.IO as Text +import qualified System.FilePath.Glob as Glob +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified System.FilePath as Path +import qualified System.Process as Process + +import Achille.Config +import Achille.Internal hiding (currentDir) +import qualified Achille.Internal as Internal +import Achille.Recipe +import Achille.Writable as Writable +import Achille.Internal.IO (AchilleIO) + + +-- | Recipe for loading a pandoc document +readPandoc :: MonadIO m + => Recipe m FilePath Pandoc +readPandoc = readPandocWith def + +-- | Recipe for loading a pandoc document using a given reader config +readPandocWith :: MonadIO m + => ReaderOptions -> Recipe m FilePath Pandoc +readPandocWith ropts = nonCached \Context{..} -> + let ext = drop 1 $ takeExtension inputValue + Just reader = lookup (pack ext) readers + in case reader of + ByteStringReader f -> liftIO $ + LazyByteString.readFile (inputDir currentDir inputValue) + >>= runIOorExplode <$> f ropts + TextReader f -> liftIO $ + Text.readFile (inputDir currentDir inputValue) + >>= runIOorExplode <$> f ropts + +-- | Recipe for loading a pandoc document and a frontmatter header. +readPandocMetadata :: (MonadIO m, MonadFail m, FromJSON a) + => Recipe m FilePath (a, Pandoc) +readPandocMetadata = readPandocMetadataWith def + +-- | Recipe for loading a pandoc document using a given reader config +readPandocMetadataWith :: (MonadIO m, MonadFail m, FromJSON a) + => ReaderOptions -> Recipe m FilePath (a, Pandoc) +readPandocMetadataWith ropts = nonCached \Context{..} -> do + let ext = drop 1 $ takeExtension inputValue + Just reader = lookup (pack ext) readers + contents <- liftIO $ ByteString.readFile (inputDir currentDir inputValue) + (meta, remaining) <- + case parseYamlFrontmatter contents of + Done i a -> pure (a, i) + _ -> fail $ "error while loading meta of " <> inputValue + (meta,) <$> case reader of + ByteStringReader f -> liftIO $ + runIOorExplode $ f ropts (LazyByteString.fromStrict remaining) + TextReader f -> liftIO $ + runIOorExplode $ f ropts (decodeUtf8 remaining) + +-- | Recipe to convert a Pandoc document to HTML. +renderPandoc :: MonadIO m + => Pandoc -> Recipe m a Text +renderPandoc = renderPandocWith def + +-- | Recipe to convert a Pandoc document to HTML using specified writer options. +renderPandocWith :: MonadIO m + => WriterOptions -> Pandoc -> Recipe m a Text +renderPandocWith wopts = liftIO . runIOorExplode <$> writeHtml5String wopts + +-- | Recipe to load and convert a Pandoc document to HTML. +compilePandoc :: MonadIO m + => Recipe m FilePath Text +compilePandoc = readPandoc >>= renderPandoc + +-- | Recipe to load and convert a Pandoc document to HTML. +compilePandocWith :: MonadIO m + => ReaderOptions -> WriterOptions -> Recipe m FilePath Text +compilePandocWith ropts wopts = + readPandocWith ropts >>= renderPandocWith wopts diff --git a/src/Achille/Task.hs b/src/Achille/Task.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Task.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | Defines core combinators for processing files incrementally. +module Achille.Task + ( Task + , match + , match_ + , matchFile + , matchDir + , with + , watch + , runTask + ) where + + +import Data.Functor ((<&>)) +import Control.Monad (forM, filterM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Binary (Binary) +import System.FilePath (FilePath, (), takeDirectory, takeFileName) +import System.FilePath.Glob (Pattern) +import System.Directory +import System.IO (openBinaryFile, hClose, IOMode(ReadMode)) +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) + +import qualified System.FilePath.Glob as Glob +import qualified Data.ByteString.Lazy as ByteString + +import Achille.Config (Config) +import Achille.Internal + +import qualified Achille.Config as Config +import Achille.Internal.IO (AchilleIO) +import qualified Achille.Internal.IO as AchilleIO + +-- what our tasks are caching +type MatchVoid = [(FilePath, Cache)] +type Match b = [(FilePath, (b, Cache))] +type MatchDir = [(FilePath, Cache)] +type With a b = (a, (b, Cache)) +type Watch a = (a, Cache) + + +shouldForce :: Context a -> FilePath -> Bool +shouldForce ctx x = or (Glob.match <$> forceFiles ctx <*> pure x) + +-- TODO: investigate whether we need glob at all? +-- It doesn't look like it's very fast, +-- and it doesn't allow you to do conditionals with {} +-- such as *.{jpg, png} + +-- | Run a recipe on every filepath matching a given pattern. +-- The results are cached and the recipe only recomputes +-- when the underlying file has changed since last run. +match :: (AchilleIO m, Binary a) + => Pattern -> Recipe m FilePath a -> Recipe m c [a] +match pattern (Recipe r :: Recipe m FilePath b) = Recipe \ctx -> do + let (cached, c'@Context{..}) = fromContext ctx + paths <- AchilleIO.glob (inputDir currentDir) pattern + >>= filterM (AchilleIO.doesFileExist . ((inputDir currentDir) )) + case cached :: Maybe (Match b) of + Nothing -> do + result <- forM paths \p -> + (p,) <$> r c' { inputValue = p + , cache = emptyCache + } + return (map (fst . snd) result, toCache (result :: Match b)) + Just cached -> do + result <- forM paths \p -> + case lookup p cached of + Just (v, cache) -> (p,) <$> do + tfile <- AchilleIO.getModificationTime (inputDir currentDir p) + if timestamp < tfile || shouldForce ctx (inputDir currentDir p) then + r c' {inputValue = p, cache = cache} + else pure (v, cache) + Nothing -> (p,) <$> r c' {inputValue = p, cache = emptyCache} + return (map (fst . snd) result, toCache (result :: Match b)) + + +-- | Run a recipe on every filepath matching a given pattern, +-- and discard the result. +-- Filepaths are cached and the recipe only recomputes when +-- the underlying file has changed since last run. +match_ :: AchilleIO m => Pattern -> Recipe m FilePath a -> Task m () +match_ pattern (Recipe r) = Recipe \ctx -> do + let (result, c'@Context{..}) = fromContext ctx + paths <- AchilleIO.glob (inputDir currentDir) pattern + >>= filterM (AchilleIO.doesFileExist . ((inputDir currentDir) )) + case result :: Maybe MatchVoid of + Nothing -> do + result <- forM paths \p -> + ((p,) . snd) <$> r c' { inputValue = p + , cache = emptyCache + } + return (() , toCache (result :: MatchVoid)) + Just cached -> do + result <- forM paths \p -> + case lookup p cached of + Just cache -> (p,) <$> do + tfile <- AchilleIO.getModificationTime (inputDir currentDir p) + if timestamp < tfile || shouldForce ctx (inputDir currentDir p) then + snd <$> r c' {inputValue = p, cache = cache} + else pure cache + Nothing -> ((p,) . snd) <$> r c' {inputValue = p, cache = emptyCache} + return ((), toCache (result :: MatchVoid)) + + +-- | Run a recipe for a filepath matching a given pattern. +-- The result is cached and the recipe only recomputes +-- when the underlying file has changed since last run. +-- Will fail is no file is found matching the pattern. +matchFile :: (AchilleIO m, Binary a) + => Pattern -> Recipe m FilePath a -> Recipe m b a +matchFile p (Recipe r :: Recipe m FilePath a) = Recipe \ctx@Context{..} -> + AchilleIO.glob (inputDir currentDir) p >>= \case + [] -> AchilleIO.fail $ unwords + [ "No file was found matching pattern" + , Glob.decompile p + , "inside directory" + , currentDir + ] + (p:xs) -> + let (result, c'@Context{..}) = fromContext ctx + in case result :: Maybe (Watch a) of + Nothing -> r c' {cache = emptyCache, inputValue = p} + <&> \v -> (fst v, toCache (v :: Watch a)) + Just (x, cache) -> do + tfile <- AchilleIO.getModificationTime (inputDir currentDir p) + if timestamp < tfile || shouldForce ctx (inputDir currentDir p) then + r c' {cache = cache, inputValue = p} + <&> \v -> (fst v, toCache (v :: Watch a)) + else pure (x, toCache ((x, cache) :: Watch a)) + + +-- | For every file matching the pattern, run a recipe with the +-- file as input and with the file's parent directory as current working directory. +-- The underlying recipe will be run regardless of whether the file was modified. +matchDir :: AchilleIO m + => Pattern -> Recipe m FilePath a -> Recipe m c [a] +matchDir pattern (Recipe r) = Recipe \ctx -> do + let (result, c'@Context{..}) = fromContext ctx + paths <- AchilleIO.glob (inputDir currentDir) pattern + case result :: Maybe MatchDir of + Nothing -> do + result <- forM paths \p -> + r c' { inputValue = takeFileName p + , currentDir = currentDir takeDirectory p + , cache = emptyCache + } + return (map fst result, toCache (zip paths (map snd result) :: MatchDir)) + Just cached -> do + result <- forM paths \p -> + case lookup p cached of + Just cache -> r c' { inputValue = takeFileName p + , currentDir = currentDir takeDirectory p + , cache = cache + } + Nothing -> r c' {inputValue = p, cache = emptyCache} + return (map fst result, toCache (zip paths (map snd result) :: MatchDir)) + + +-- | Cache a value and only trigger a given recipe if said value has changed between runs. +-- cache the result of the recipe. +with :: (Applicative m, Binary a, Eq a, Binary b) + => a -> Recipe m c b -> Recipe m c b +with (x :: a) (Recipe r :: Recipe m1 c d) = Recipe \ctx -> + let (result, c'@Context{..}) = fromContext ctx + in case result :: Maybe (With a d) of + Nothing -> + r c' {cache = emptyCache} + <&> \v -> (fst v, toCache ((x, v) :: With a d)) + Just (x', (v, cache)) -> + if x == x' then pure (v , toCache ((x', (v, cache)) :: With a d)) + else r c' <&> \v -> (fst v, toCache ((x, v) :: With a d)) + + +-- | Cache a value and only trigger a given recipe if said value has changed between runs. +-- Like 'with', but the result of the recipe won't be cached. +-- If the recipe must be retriggered, it will be in depth. +watch :: (Functor m, Binary a, Eq a) + => a -> Recipe m c b -> Recipe m c b +watch (x :: a) (Recipe r :: Recipe m c b) = Recipe \ctx -> + let (result, c'@Context{..}) = fromContext ctx + in case result :: Maybe (Watch a) of + Nothing -> + r c' {cache = emptyCache} + <&> \v -> (fst v, toCache ((x, snd v) :: Watch a)) + Just (x', cache) -> + r c' {mustRun = if x /= x' then MustRunOne else NoMust, cache = cache} + <&> \v -> (fst v, toCache ((x, snd v) :: Watch a)) + + +-- | Run a task using the provided config and a list of dirty files. +-- This takes care of loading the existing cache and updating it. +runTask :: MonadIO m + => [Glob.Pattern] -- ^ Files for which we force recompilation + -> Config -- ^ The config + -> Task m a -- ^ The task + -> m a +runTask force config (Recipe r) = do + cacheExists <- liftIO $ doesFileExist (Config.cacheFile config) + timestamp <- if cacheExists then + liftIO $ getModificationTime (Config.cacheFile config) + else pure (UTCTime (ModifiedJulianDay 0) 0) + let ctx = Context (Config.contentDir config) + (Config.outputDir config) + "" + timestamp + force + NoMust + (v, cache') <- + if cacheExists then do + handle <- liftIO $ openBinaryFile (Config.cacheFile config) ReadMode + cache <- liftIO $ ByteString.hGetContents handle + (value, cache') <- r (ctx cache ()) + liftIO $ hClose handle + pure (value, cache') + else do r (ctx emptyCache ()) + liftIO $ ByteString.writeFile (Config.cacheFile config) cache' + pure v diff --git a/src/Achille/Timestamped.hs b/src/Achille/Timestamped.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Timestamped.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Defines utilies for working with timestamped things. +module Achille.Timestamped + ( Timestamped(..) + , IsTimestamped + , timestamp + , timestamped + , timestampedWith + , compareTimestamped + , recentFirst + , oldFirst + ) where + +import Data.Ord (Ord, compare, Ordering) +import System.FilePath (FilePath) +import Data.List (sortBy, sort) +import Data.Typeable (Typeable) +import Data.Binary (Binary, put, get) +import Data.Time.Calendar (fromGregorian) +import Data.Time (UTCTime(..), secondsToDiffTime) +import Data.Time.Format (readSTime, defaultTimeLocale) +import System.FilePath (takeFileName) +import Data.Binary.Instances.Time () + +-- | Container for timestamping data. +data Timestamped a = Timestamped UTCTime a + deriving (Show, Eq, Ord, Typeable, Functor) + +instance Binary a => Binary (Timestamped a) where + put (Timestamped d x) = put d >> put x + get = Timestamped <$> get <*> get + + +-- | Class for values that can be timestamped. +class IsTimestamped a where + -- | Retrieve a datetime from a value. + timestamp :: a -> UTCTime + +instance IsTimestamped (Timestamped a) where + timestamp (Timestamped d _) = d + +instance IsTimestamped FilePath where + timestamp p = + case readSTime False defaultTimeLocale "%Y-%m-%d" (takeFileName p) of + [(t, _)] -> t + _ -> UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0) + + +-- | Wrap a value that can be timestamped. +timestamped :: IsTimestamped a => a -> Timestamped a +timestamped x = Timestamped (timestamp x) x + +-- | Wrap a value that can be timestamped, using the given function for +-- retrieving the timestamp. +timestampedWith :: (a -> UTCTime) -> a -> Timestamped a +timestampedWith f x = Timestamped (f x) x + +-- | Compare two timestamped values. +compareTimestamped :: IsTimestamped a => a -> a -> Ordering +compareTimestamped x y = compare (timestamp x) (timestamp y) + +-- | Sort timestamped values from most recent to oldest. +recentFirst :: IsTimestamped a => [a] -> [a] +recentFirst = sortBy (flip compareTimestamped) + +-- | Sort timestamped values from oldest to most recent. +oldFirst :: IsTimestamped a => [a] -> [a] +oldFirst = sortBy compareTimestamped diff --git a/src/Achille/Writable.hs b/src/Achille/Writable.hs new file mode 100644 --- /dev/null +++ b/src/Achille/Writable.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Defines an interface for things that can be written to disk. +module Achille.Writable where + +import Data.Text as Text +import qualified Data.Text.Lazy as LT +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8) +import Data.ByteString as BS +import Data.ByteString.Lazy as LBS + +import qualified Data.ByteString.Lazy as ByteString + +import Achille.Internal.IO as AchilleIO + + +-- | Class for things that can be saved. +class Writable m a where + write :: FilePath -> a -> m () + +instance AchilleIO m => Writable m [Char] where + write to = write to . Text.pack + +instance AchilleIO m => Writable m Text where + write to = AchilleIO.writeFile to . encodeUtf8 + +instance AchilleIO m => Writable m LT.Text where + write to = AchilleIO.writeFileLazy to . LT.encodeUtf8 + +instance AchilleIO m => Writable m BS.ByteString where + write = AchilleIO.writeFile + +instance AchilleIO m => Writable m LBS.ByteString where + write = AchilleIO.writeFileLazy diff --git a/tests/FakeIO.hs b/tests/FakeIO.hs new file mode 100644 --- /dev/null +++ b/tests/FakeIO.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables #-} + +module FakeIO where + + +import Data.Time.Clock (UTCTime) +import Data.Map.Strict as M +import Data.Maybe +import Data.Bifunctor (bimap) +import Control.Monad.Fail (MonadFail, fail) + +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified System.FilePath.Glob as Glob +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Control.Monad.State + +import Test.Tasty.HUnit + +import Achille.Recipe +import Achille.Internal +import Achille.Internal.IO as AchilleIO + + +data FakeIO a where + ReadFile :: FilePath -> FakeIO BS.ByteString + ReadFileLazy :: FilePath -> FakeIO LBS.ByteString + CopyFile :: FilePath -> FilePath -> FakeIO () + WriteFile :: FilePath -> BS.ByteString -> FakeIO () + WriteFileLazy :: FilePath -> LBS.ByteString -> FakeIO () + DoesFileExist :: FilePath -> FakeIO Bool + DoesDirExist :: FilePath -> FakeIO Bool + CallCommand :: String -> FakeIO () + Log :: String -> FakeIO () + Glob :: FilePath -> Glob.Pattern -> FakeIO [FilePath] + GetModificationTime :: FilePath -> FakeIO UTCTime + Fail :: String -> FakeIO a + + SeqAp :: FakeIO (a -> b) -> FakeIO a -> FakeIO b + Fmap :: (a -> b) -> FakeIO a -> FakeIO b + Pure :: a -> FakeIO a + Bind :: FakeIO a -> (a -> FakeIO b) -> FakeIO b + + +instance Functor FakeIO where + fmap = Fmap + +instance Applicative FakeIO where + pure = Pure + (<*>) = SeqAp + +instance Monad FakeIO where + (>>=) = Bind + +instance MonadFail FakeIO where + fail = Fail + + +instance AchilleIO FakeIO where + readFile = ReadFile + readFileLazy = ReadFileLazy + copyFile = CopyFile + writeFile = WriteFile + writeFileLazy = WriteFileLazy + doesFileExist = DoesFileExist + doesDirExist = DoesDirExist + callCommand = CallCommand + log = Log + glob = Glob + getModificationTime = GetModificationTime + + +data FakeIOActions + = WrittenFile FilePath BS.ByteString + | WrittenFileLazy FilePath LBS.ByteString + | HasReadFile FilePath + | HasReadFileLazy FilePath + | CopiedFile FilePath FilePath + | CalledCommand String + | Failed String + deriving (Eq, Show) + + +type FileSystem = Map FilePath (UTCTime, BS.ByteString) + +defMTime :: UTCTime +defMTime = undefined + +getMTime :: FilePath -> FileSystem -> UTCTime +getMTime p fs = fromMaybe defMTime (fst <$> M.lookup p fs) + +getBS :: FilePath -> FileSystem -> BS.ByteString +getBS p fs = fromMaybe BS.empty (snd <$> M.lookup p fs) + +retrieveFakeIOActions :: FakeIO (a, Cache) -- the fake IO computation + -> FileSystem -- the underlying input FS + -> (Maybe a, [FakeIOActions]) +retrieveFakeIOActions t fs = bimap (fmap fst) reverse $ runState (retrieve t) [] + where + retrieve :: FakeIO a -> State [FakeIOActions] (Maybe a) + retrieve (ReadFile key) = do + modify (HasReadFile key :) + pure (Just $ getBS key fs) + + retrieve (ReadFileLazy key) = do + modify (HasReadFileLazy key :) + pure (Just $ LBS.fromStrict $ getBS key fs) + + retrieve (CopyFile from to) = Just <$> modify (CopiedFile from to :) + retrieve (WriteFile p c) = Just <$> modify (WrittenFile p c :) + retrieve (WriteFileLazy p c) = Just <$> modify (WrittenFileLazy p c :) + retrieve (DoesFileExist p) = undefined + + retrieve (CallCommand cmd) = Just <$> modify (CalledCommand cmd :) + retrieve (Log str) = pure $ Just () + retrieve (Glob dir p) = undefined + retrieve (GetModificationTime p) = pure $ Just (getMTime p fs) + + retrieve (SeqAp f x) = do + actions <- get + let (Just f', actions') = runState (retrieve f) actions + let (Just x', actions'') = runState (retrieve x) actions' + put actions'' + pure $ Just (f' x') + + retrieve (Fmap f x) = do + actions <- get + let (Just x', actions') = runState (retrieve x) actions + put actions' + pure $ Just (f x') + + retrieve (Pure x) = pure (Just x) + retrieve (Fail str) = modify (Failed str :) >> pure Nothing + + retrieve (Bind (Fail str) f) = modify (Failed str :) >> pure Nothing + + retrieve (Bind x f) = do + actions <- get + let (Just x', actions') = runState (retrieve x) actions + put actions' + retrieve (f x') + + +exactRun :: (Show b, Eq b) + => FileSystem + -> Context a + -> Recipe FakeIO a b + -> (Maybe b, [FakeIOActions]) + -> Assertion +exactRun fs ctx r expected = + let fakeIO = runRecipe r ctx + trace = retrieveFakeIOActions fakeIO fs + in trace @?= expected diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Test.Tasty +import Test.Tasty.Ingredients.ConsoleReporter +import Test.Tasty.HUnit + +import FakeIO +import Achille.Recipe +import Achille.Internal +import System.FilePath +import qualified Data.Map.Strict as M +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) + +fs :: FileSystem +fs = M.fromList + [ ("content" "fichier.txt", + (defMTime, "helloworld")) + ] + +testCtx :: a -> Context a +testCtx x = Context + { inputDir = "content" + , outputDir = "output" + , currentDir = "" + , timestamp = defMTime + , forceFiles = [] + , mustRun = NoMust + , cache = LBS.empty + , inputValue = x + } + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ testCase "Write on the fs and get the output path back:" $ + exactRun fs (testCtx ()) + (write "somewhere.txt" ("somestuff" :: Text)) + (Just "somewhere.txt", [ WrittenFile "output/somewhere.txt" "somestuff" ]) + + , testCase "Read text from the fs" $ + exactRun fs (testCtx "fichier.txt") + (readText) + (Just "helloworld", [ HasReadFile "content/fichier.txt" ]) + + , testCase "Read text and write it to the fs" $ + exactRun fs (testCtx "fichier.txt") + (readText >>= saveFile) + (Just "fichier.txt", [ HasReadFile "content/fichier.txt" + , WrittenFile "output/fichier.txt" "helloworld" ]) + , testCase "Copy file" $ + exactRun fs (testCtx ()) + (copy "un.txt" "deux.txt") + (Just "deux.txt", [ CopiedFile "content/un.txt" "output/deux.txt" ]) + ] +