From 720c92ab1ef628c3c9545fa022ed546c60d9d72a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 29 Dec 2012 09:53:59 +0100 Subject: Move preview modules --- src/Hakyll/Main.hs | 4 ++-- src/Hakyll/Preview/Poll.hs | 48 ++++++++++++++++++++++++++++++++++++++++ src/Hakyll/Preview/Server.hs | 43 +++++++++++++++++++++++++++++++++++ src/Hakyll/Web/Preview/Poll.hs | 43 ----------------------------------- src/Hakyll/Web/Preview/Server.hs | 40 --------------------------------- 5 files changed, 93 insertions(+), 85 deletions(-) create mode 100644 src/Hakyll/Preview/Poll.hs create mode 100644 src/Hakyll/Preview/Server.hs delete mode 100644 src/Hakyll/Web/Preview/Poll.hs delete mode 100644 src/Hakyll/Web/Preview/Server.hs (limited to 'src/Hakyll') diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 37dc0fa..3ead225 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -28,8 +28,8 @@ 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 +import Hakyll.Preview.Poll +import Hakyll.Preview.Server #endif 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 diff --git a/src/Hakyll/Web/Preview/Poll.hs b/src/Hakyll/Web/Preview/Poll.hs deleted file mode 100644 index 7ea033f..0000000 --- a/src/Hakyll/Web/Preview/Poll.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Interval-based implementation of preview polling --- -{-# LANGUAGE CPP #-} -module Hakyll.Web.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 (getModificationTime, doesFileExist) - -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/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs deleted file mode 100644 index 15a1a33..0000000 --- a/src/Hakyll/Web/Preview/Server.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | Implements a basic static file server for previewing options --- -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Web.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 -- cgit v1.2.3