Add snapshots
This commit is contained in:
parent
bc192a127b
commit
0a6b2b2598
6 changed files with 138 additions and 60 deletions
|
@ -10,9 +10,16 @@ module Hakyll.Core.Compiler
|
|||
, getResourceString
|
||||
, getResourceLBS
|
||||
, getResourceWith
|
||||
, require
|
||||
, requireBody
|
||||
, requireAll
|
||||
|
||||
, Internal.Snapshot
|
||||
, saveSnapshot
|
||||
, Internal.require
|
||||
, Internal.requireSnapshot
|
||||
, Internal.requireBody
|
||||
, Internal.requireSnapshotBody
|
||||
, Internal.requireAll
|
||||
, Internal.requireAllSnapshots
|
||||
|
||||
, cached
|
||||
, unsafeCompiler
|
||||
, debugCompiler
|
||||
|
@ -30,7 +37,7 @@ import System.Environment (getProgName)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
import Hakyll.Core.Compiler.Internal
|
||||
import Hakyll.Core.Compiler.Require
|
||||
import qualified Hakyll.Core.Compiler.Require as Internal
|
||||
import Hakyll.Core.Identifier
|
||||
import Hakyll.Core.Item
|
||||
import Hakyll.Core.Logger as Logger
|
||||
|
@ -93,6 +100,14 @@ getResourceWith reader = do
|
|||
show fp ++ " not found"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
saveSnapshot :: (Binary a, Typeable a)
|
||||
=> Internal.Snapshot -> Item a -> Compiler ()
|
||||
saveSnapshot snapshot item = do
|
||||
store <- compilerStore <$> compilerAsk
|
||||
compilerUnsafeIO $ Internal.saveSnapshot store snapshot item
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
cached :: (Binary a, Typeable a)
|
||||
=> String
|
||||
|
|
|
@ -1,9 +1,14 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Hakyll.Core.Compiler.Require
|
||||
( save
|
||||
( Snapshot
|
||||
, save
|
||||
, saveSnapshot
|
||||
, require
|
||||
, requireSnapshot
|
||||
, requireBody
|
||||
, requireSnapshotBody
|
||||
, requireAll
|
||||
, requireAllSnapshots
|
||||
) where
|
||||
|
||||
|
||||
|
@ -25,45 +30,82 @@ import qualified Hakyll.Core.Store as Store
|
|||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
save :: (Binary a, Typeable a) => Store -> Identifier -> a -> IO ()
|
||||
save store identifier x = Store.set store (key identifier) x
|
||||
type Snapshot = String
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
|
||||
save store item = saveSnapshot store final item
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
saveSnapshot :: (Binary a, Typeable a)
|
||||
=> Store -> Snapshot -> Item a -> IO ()
|
||||
saveSnapshot store snapshot item =
|
||||
Store.set store (key (itemIdentifier item) snapshot) (itemBody item)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
require :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)
|
||||
require id' = do
|
||||
require id' = requireSnapshot id' final
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
requireSnapshot :: (Binary a, Typeable a)
|
||||
=> Identifier -> Snapshot -> Compiler (Item a)
|
||||
requireSnapshot id' snapshot = do
|
||||
store <- compilerStore <$> compilerAsk
|
||||
|
||||
compilerTellDependencies [IdentifierDependency id']
|
||||
compilerResult $ CompilerRequire id' $ do
|
||||
result <- compilerUnsafeIO $ Store.get store (key id')
|
||||
result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
|
||||
case result of
|
||||
Store.NotFound -> compilerThrow notFound
|
||||
Store.WrongType e r -> compilerThrow $ wrongType e r
|
||||
Store.Found x -> return $ Item id' x
|
||||
where
|
||||
notFound =
|
||||
"Hakyll.Core.Compiler.Require.require: " ++ show id' ++ " was " ++
|
||||
"not found in the cache, the cache might be corrupted or " ++
|
||||
"Hakyll.Core.Compiler.Require.require: " ++ show id' ++
|
||||
" (snapshot " ++ snapshot ++ ") was not found in the cache, " ++
|
||||
"the cache might be corrupted or " ++
|
||||
"the item you are referring to might not exist"
|
||||
wrongType e r =
|
||||
"Hakyll.Core.Compiler.Require.require: " ++ show id' ++ " was found " ++
|
||||
"in the cache, but does not have the right type: expected " ++ show e ++
|
||||
"Hakyll.Core.Compiler.Require.require: " ++ show id' ++
|
||||
" (snapshot " ++ snapshot ++ ") was found in the cache, " ++
|
||||
"but does not have the right type: expected " ++ show e ++
|
||||
" but got " ++ show r
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
requireBody :: (Binary a, Typeable a) => Identifier -> Compiler a
|
||||
requireBody = fmap itemBody . require
|
||||
requireBody id' = requireSnapshotBody id' final
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
requireSnapshotBody :: (Binary a, Typeable a)
|
||||
=> Identifier -> Snapshot -> Compiler a
|
||||
requireSnapshotBody id' snapshot = fmap itemBody $ requireSnapshot id' snapshot
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
requireAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]
|
||||
requireAll pattern = do
|
||||
matching <- getMatches pattern
|
||||
mapM require matching
|
||||
requireAll pattern = requireAllSnapshots pattern final
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
key :: Identifier -> [String]
|
||||
key identifier = ["Hakyll.Core.Compiler.Require", show identifier]
|
||||
requireAllSnapshots :: (Binary a, Typeable a)
|
||||
=> Pattern -> Snapshot -> Compiler [Item a]
|
||||
requireAllSnapshots pattern snapshot = do
|
||||
matching <- getMatches pattern
|
||||
mapM (\i -> requireSnapshot i snapshot) matching
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
key :: Identifier -> String -> [String]
|
||||
key identifier snapshot =
|
||||
["Hakyll.Core.Compiler.Require", show identifier, snapshot]
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
final :: Snapshot
|
||||
final = "final"
|
||||
|
|
|
@ -27,7 +27,6 @@ import Hakyll.Core.Compiler.Require
|
|||
import Hakyll.Core.Configuration
|
||||
import Hakyll.Core.Dependencies
|
||||
import Hakyll.Core.Identifier
|
||||
import Hakyll.Core.Item
|
||||
import Hakyll.Core.Item.SomeItem
|
||||
import Hakyll.Core.Logger (Logger)
|
||||
import qualified Hakyll.Core.Logger as Logger
|
||||
|
@ -194,8 +193,7 @@ chase trail id'
|
|||
-- Huge success
|
||||
CompilerDone (SomeItem item) cwrite -> do
|
||||
-- TODO: Sanity check on itemIdentifier?
|
||||
let body = itemBody item
|
||||
facts = compilerDependencies cwrite
|
||||
let facts = compilerDependencies cwrite
|
||||
cacheHits
|
||||
| compilerCacheHits cwrite <= 0 = "updated"
|
||||
| otherwise = "cached "
|
||||
|
@ -213,7 +211,7 @@ chase trail id'
|
|||
Logger.debug logger $ "Routed to " ++ path
|
||||
|
||||
-- Save! (For require)
|
||||
liftIO $ save store id' body
|
||||
liftIO $ save store item
|
||||
|
||||
-- Update state
|
||||
modify $ \s -> s
|
||||
|
|
|
@ -1,39 +1,47 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Module providing the main hakyll function and command-line argument parsing
|
||||
--
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Hakyll.Main
|
||||
( hakyll
|
||||
, hakyllWith
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
|
||||
import System.Environment (getProgName, getArgs)
|
||||
import System.Process (system)
|
||||
|
||||
import Hakyll.Core.Configuration
|
||||
import Hakyll.Core.Identifier
|
||||
import Hakyll.Core.Runtime
|
||||
import Hakyll.Core.Rules
|
||||
--------------------------------------------------------------------------------
|
||||
import Control.Monad (when)
|
||||
import System.Directory (doesDirectoryExist,
|
||||
removeDirectoryRecursive)
|
||||
import System.Environment (getArgs, getProgName)
|
||||
import System.Process (system)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Hakyll.Core.Configuration
|
||||
import Hakyll.Core.Rules
|
||||
import Hakyll.Core.Runtime
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
#ifdef PREVIEW_SERVER
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent (forkIO)
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Hakyll.Core.Rules.Internal
|
||||
import Hakyll.Web.Preview.Poll
|
||||
import Hakyll.Web.Preview.Server
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent (forkIO)
|
||||
import qualified Data.Set as S
|
||||
import Hakyll.Core.Identifier
|
||||
import Hakyll.Core.Rules.Internal
|
||||
import Hakyll.Web.Preview.Poll
|
||||
import Hakyll.Web.Preview.Server
|
||||
#endif
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | This usualy is the function with which the user runs the hakyll compiler
|
||||
--
|
||||
hakyll :: Rules a -> IO ()
|
||||
hakyll = hakyllWith defaultConfiguration
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | A variant of 'hakyll' which allows the user to specify a custom
|
||||
-- configuration
|
||||
--
|
||||
hakyllWith :: Configuration -> Rules a -> IO ()
|
||||
hakyllWith conf rules = do
|
||||
args <- getArgs
|
||||
|
@ -49,15 +57,17 @@ hakyllWith conf rules = do
|
|||
["deploy"] -> deploy conf
|
||||
_ -> help
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Build the site
|
||||
--
|
||||
build :: Configuration -> Rules a -> IO ()
|
||||
build conf rules = do
|
||||
_ <- run conf rules
|
||||
return ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Remove the output directories
|
||||
--
|
||||
clean :: Configuration -> IO ()
|
||||
clean conf = do
|
||||
remove $ destinationDirectory conf
|
||||
|
@ -68,8 +78,9 @@ clean conf = do
|
|||
exists <- doesDirectoryExist dir
|
||||
when exists $ removeDirectoryRecursive dir
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Show usage information.
|
||||
--
|
||||
help :: IO ()
|
||||
help = do
|
||||
name <- getProgName
|
||||
|
@ -95,8 +106,9 @@ help = do
|
|||
previewServerDisabled
|
||||
#endif
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Preview the site
|
||||
--
|
||||
preview :: Configuration -> Rules a -> Int -> IO ()
|
||||
#ifdef PREVIEW_SERVER
|
||||
preview conf rules port = do
|
||||
|
@ -111,15 +123,17 @@ preview conf rules port = do
|
|||
preview _ _ _ = previewServerDisabled
|
||||
#endif
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Rebuild the site
|
||||
--
|
||||
rebuild :: Configuration -> Rules a -> IO ()
|
||||
rebuild conf rules = do
|
||||
clean conf
|
||||
build conf rules
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Start a server
|
||||
--
|
||||
server :: Configuration -> Int -> IO ()
|
||||
#ifdef PREVIEW_SERVER
|
||||
server conf port = do
|
||||
|
@ -131,15 +145,17 @@ server conf port = do
|
|||
server _ _ = previewServerDisabled
|
||||
#endif
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Upload the site
|
||||
--
|
||||
deploy :: Configuration -> IO ()
|
||||
deploy conf = do
|
||||
_ <- system $ deployCommand conf
|
||||
return ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Print a warning message about the preview serving not being enabled
|
||||
--
|
||||
#ifndef PREVIEW_SERVER
|
||||
previewServerDisabled :: IO ()
|
||||
previewServerDisabled =
|
||||
|
|
|
@ -6,17 +6,14 @@ module Hakyll.Core.Runtime.Tests
|
|||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import System.FilePath ((</>))
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.HUnit (Assertion, (@?=))
|
||||
import System.FilePath ((</>))
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.HUnit (Assertion, (@?=))
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Hakyll.Core.Configuration
|
||||
import Hakyll.Core.Routes
|
||||
import Hakyll.Core.Rules
|
||||
import Hakyll
|
||||
import Hakyll.Core.Runtime
|
||||
import Hakyll.Web.Page
|
||||
import TestSuite.Util
|
||||
|
||||
|
||||
|
@ -31,7 +28,18 @@ case01 = withTestConfiguration $ \config -> do
|
|||
_ <- run config $ do
|
||||
match "*.md" $ do
|
||||
route $ setExtension "html"
|
||||
compile $ pageCompiler
|
||||
compile $ do
|
||||
body <- getResourceBody
|
||||
saveSnapshot "raw" body
|
||||
return $ renderPandoc body
|
||||
|
||||
out <- readFile $ destinationDirectory config </> "example.html"
|
||||
lines out @?= ["<p>This is an example.</p>"]
|
||||
match "bodies.txt" $ route idRoute
|
||||
create "bodies.txt" $ do
|
||||
items <- requireAllSnapshots "*.md" "raw" :: Compiler [Item String]
|
||||
makeItem $ concat $ map itemBody items
|
||||
|
||||
example <- readFile $ destinationDirectory config </> "example.html"
|
||||
lines example @?= ["<p>This is an example.</p>"]
|
||||
|
||||
bodies <- readFile $ destinationDirectory config </> "bodies.txt"
|
||||
head (lines bodies) @?= "This is an example."
|
||||
|
|
|
@ -61,7 +61,6 @@ wrongType = withTestStore $ \store -> do
|
|||
-- Store a string and try to fetch an int
|
||||
Store.set store ["foo", "bar"] ("qux" :: String)
|
||||
value <- Store.get store ["foo", "bar"] :: IO (Store.Result Int)
|
||||
print value
|
||||
H.assert $ case value of
|
||||
Store.WrongType e t ->
|
||||
e == typeOf (undefined :: Int) &&
|
||||
|
|
Loading…
Reference in a new issue