Move preview modules

2 files changed, 91 insertions, 0 deletions

diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs
new file mode 100644
index 0000000..55118b3
--- /dev/null
+++ b/src/Hakyll/Preview/Poll.hs
@@ -0,0 +1,48 @@
+--------------------------------------------------------------------------------
+-- | Interval-based implementation of preview polling
+{-# LANGUAGE CPP #-}
+module Hakyll.Preview.Poll
+    ( previewPoll
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Applicative       ((<$>))
+import           Control.Concurrent        (threadDelay)
+import           Control.Monad             (filterM)
+#if MIN_VERSION_directory(1,2,0)
+import           Data.Time                 (getCurrentTime)
+#else
+import           System.Time               (getClockTime)
+#endif
+import           System.Directory          (doesFileExist, getModificationTime)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Configuration
+
+
+--------------------------------------------------------------------------------
+-- | A preview thread that periodically recompiles the site.
+previewPoll :: Configuration  -- ^ Configuration
+            -> IO [FilePath]  -- ^ Updating action
+            -> IO ()          -- ^ Can block forever
+previewPoll _ update = do
+#if MIN_VERSION_directory(1,2,0)
+    time <- getCurrentTime
+#else
+    time <- getClockTime
+#endif
+    loop time =<< update
+  where
+    delay = 1000000
+    loop time files = do
+        threadDelay delay
+        files' <- filterM doesFileExist files
+        filesTime <- case files' of
+            []  -> return time
+            _   -> maximum <$> mapM getModificationTime files'
+
+        if filesTime > time || files' /= files
+            then loop filesTime =<< update
+            else loop time files'
diff --git a/src/Hakyll/Preview/Server.hs b/src/Hakyll/Preview/Server.hs
new file mode 100644
index 0000000..14cf377
--- /dev/null
+++ b/src/Hakyll/Preview/Server.hs
@@ -0,0 +1,43 @@
+--------------------------------------------------------------------------------
+-- | Implements a basic static file server for previewing options
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Preview.Server
+    ( staticServer
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Monad.Trans (liftIO)
+import qualified Snap.Core           as Snap
+import qualified Snap.Http.Server    as Snap
+import qualified Snap.Util.FileServe as Snap
+
+
+--------------------------------------------------------------------------------
+-- | Serve a given directory
+static :: FilePath             -- ^ Directory to serve
+       -> (FilePath -> IO ())  -- ^ Pre-serve hook
+       -> Snap.Snap ()
+static directory preServe =
+    Snap.serveDirectoryWith directoryConfig directory
+  where
+    directoryConfig :: Snap.DirectoryConfig Snap.Snap
+    directoryConfig = Snap.fancyDirectoryConfig
+        { Snap.preServeHook = liftIO . preServe
+        }
+
+
+--------------------------------------------------------------------------------
+-- | Main method, runs a static server in the given directory
+staticServer :: FilePath             -- ^ Directory to serve
+             -> (FilePath -> IO ())  -- ^ Pre-serve hook
+             -> Int                  -- ^ Port to listen on
+             -> IO ()                -- ^ Blocks forever
+staticServer directory preServe port =
+    Snap.httpServe config $ static directory preServe
+  where
+    -- Snap server config
+    config = Snap.setPort      port
+           $ Snap.setAccessLog Snap.ConfigNoLog
+           $ Snap.setErrorLog  Snap.ConfigNoLog
+           $ Snap.emptyConfig