Rewrote preview mode.

Preview mode is now based on server requests
instead of time intervals. This should solve
some problems out there.

3 files changed, 29 insertions, 33 deletions

diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs
index f17c490..4eef689 100644
--- a/src/Network/Hakyll/SimpleServer.hs
+++ b/src/Network/Hakyll/SimpleServer.hs
@@ -188,8 +188,12 @@ respond handle = do
 
 -- | Start a simple http server on the given 'PortNumber', serving the given
 --   directory.
-simpleServer :: PortNumber -> FilePath -> IO ()
-simpleServer port root = do
+--
+simpleServer :: PortNumber  -- ^ Port to listen on.
+             -> FilePath    -- ^ Root directory to serve.
+             -> IO ()       -- ^ Optional pre-respond action.
+             -> IO ()
+simpleServer port root preRespond = do
     -- Channel to send logs to
     logChan <- newChan
 
@@ -200,6 +204,7 @@ simpleServer port root = do
 
           -- When a client connects, respond in a separate thread.
         listen socket = do (handle, _, _) <- accept socket
+                           preRespond
                            forkIO (runReaderT (respond handle) config)
 
     -- Handle logging in a separate thread
diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs
index 8f74556..517c68d 100644
--- a/src/Text/Hakyll.hs
+++ b/src/Text/Hakyll.hs
@@ -14,20 +14,18 @@ module Text.Hakyll
     ) where
 
 import Control.Monad.Reader (runReaderT, liftIO, ask)
-import Control.Concurrent (forkIO, threadDelay)
 import Control.Monad (when)
 import qualified Data.Map as M
 import System.Environment (getArgs, getProgName)
 import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
-import System.Time (getClockTime)
 
 import Text.Pandoc
 
 import Network.Hakyll.SimpleServer (simpleServer)
 import Text.Hakyll.HakyllMonad
-import Text.Hakyll.File
 
 -- | The default reader options for pandoc parsing.
+--
 defaultPandocParserState :: ParserState
 defaultPandocParserState = defaultParserState
     { -- The following option causes pandoc to read smart typography, a nice
@@ -36,6 +34,7 @@ defaultPandocParserState = defaultParserState
     }
 
 -- | The default writer options for pandoc rendering.
+--
 defaultPandocWriterOptions :: WriterOptions
 defaultPandocWriterOptions = defaultWriterOptions
     { -- This option causes literate haskell to be written using '>' marks in
@@ -44,6 +43,7 @@ defaultPandocWriterOptions = defaultWriterOptions
     }
 
 -- | The default hakyll configuration.
+--
 defaultHakyllConfiguration :: HakyllConfiguration
 defaultHakyllConfiguration = HakyllConfiguration
     { absoluteUrl         = ""
@@ -51,14 +51,14 @@ defaultHakyllConfiguration = HakyllConfiguration
     , siteDirectory       = "_site"
     , cacheDirectory      = "_cache"
     , enableIndexUrl      = False
-    , previewPollDelay    = 1000000
     , pandocParserState   = defaultPandocParserState
     , pandocWriterOptions = defaultPandocWriterOptions
     }
 
 -- | Main function to run Hakyll with the default configuration. The
---   absolute URL is only used in certain cases, for example RSS feeds et
---   cetera.
+-- absolute URL is only used in certain cases, for example RSS feeds et
+-- cetera.
+--
 hakyll :: String    -- ^ Absolute URL of your site. Used in certain cases.
        -> Hakyll () -- ^ You code.
        -> IO ()
@@ -67,20 +67,22 @@ hakyll absolute = hakyllWithConfiguration configuration
     configuration = defaultHakyllConfiguration { absoluteUrl = absolute }
 
 -- | Main function to run hakyll with a custom configuration.
+--
 hakyllWithConfiguration :: HakyllConfiguration -> Hakyll () -> IO ()
 hakyllWithConfiguration configuration buildFunction = do
     args <- getArgs
     let f = case args of ["build"]      -> buildFunction
                          ["clean"]      -> clean
-                         ["preview", p] -> preview buildFunction (read p)
-                         ["preview"]    -> preview buildFunction 8000
+                         ["preview", p] -> server (read p) buildFunction
+                         ["preview"]    -> server 8000 buildFunction
                          ["rebuild"]    -> clean >> buildFunction
-                         ["server", p]  -> server (read p)
-                         ["server"]     -> server 8000
+                         ["server", p]  -> server (read p) (return ())
+                         ["server"]     -> server 8000 (return ())
                          _              -> help
     runReaderT f configuration
 
 -- | Clean up directories.
+--
 clean :: Hakyll ()
 clean = do askHakyll siteDirectory >>= remove'
            askHakyll cacheDirectory >>= remove'
@@ -89,24 +91,8 @@ clean = do askHakyll siteDirectory >>= remove'
                               exists <- doesDirectoryExist dir
                               when exists $ removeDirectoryRecursive dir
 
--- | Autocompile mode.
-preview :: Hakyll () -> Integer -> Hakyll ()
-preview buildFunction port = do
-    buildFunction
-    _ <- startServer
-    liftIO getClockTime >>= run
-  where
-    startServer = do configuration <- ask
-                     liftIO $ forkIO $ runReaderT (server port) configuration
-    run time = do delay <- askHakyll previewPollDelay
-                  liftIO $ threadDelay delay
-                  contents <- getRecursiveContents "."
-                  valid <- isMoreRecent time contents
-                  if valid then run time
-                           else do buildFunction
-                                   liftIO getClockTime >>= run
-
 -- | Show usage information.
+--
 help :: Hakyll ()
 help = liftIO $ do
     name <- getProgName
@@ -122,5 +108,12 @@ help = liftIO $ do
              ++ name ++ " server [port]   Run a local test server.\n"
 
 -- | Start a server at the given port number.
-server :: Integer -> Hakyll ()
-server p = askHakyll siteDirectory >>= liftIO . simpleServer (fromIntegral p)
+--
+server :: Integer    -- ^ Port number to serve on.
+       -> Hakyll ()  -- ^ Pre-respond action.
+       -> Hakyll ()
+server port preRespond = do 
+    configuration <- ask
+    root <- askHakyll siteDirectory
+    let preRespondIO = runReaderT preRespond configuration
+    liftIO $ simpleServer (fromIntegral port) root preRespondIO
diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs
index fbfe5ae..372fad1 100644
--- a/src/Text/Hakyll/HakyllMonad.hs
+++ b/src/Text/Hakyll/HakyllMonad.hs
@@ -30,8 +30,6 @@ data HakyllConfiguration = HakyllConfiguration
       cacheDirectory      :: FilePath
     , -- | Enable index links.
       enableIndexUrl      :: Bool
-    , -- | Delay between polls in preview mode.
-      previewPollDelay    :: Int
     , -- | Pandoc parsing options
       pandocParserState   :: ParserState
     , -- | Pandoc writer options