From d66155968fa02b85eb751c68f20d3a6bb708b5e6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 10 Feb 2011 16:04:55 +0100 Subject: Move preview server, update to snap 0.4 --- src/Hakyll/Main.hs | 2 +- src/Hakyll/Network/Server.hs | 72 ---------------------------------------- src/Hakyll/Web/Preview/Server.hs | 72 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+), 73 deletions(-) delete mode 100644 src/Hakyll/Network/Server.hs create 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 36a4010..1d60e47 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -12,7 +12,7 @@ import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import Hakyll.Core.Configuration import Hakyll.Core.Run import Hakyll.Core.Rules -import Hakyll.Network.Server +import Hakyll.Web.Preview.Server -- | This usualy is the function with which the user runs the hakyll compiler -- diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs deleted file mode 100644 index 0e25959..0000000 --- a/src/Hakyll/Network/Server.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Implements a basic static file server for previewing options --- -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Network.Server - ( staticServer - ) where - -import Control.Monad.Trans (liftIO) -import Control.Applicative ((<$>)) -import Codec.Binary.UTF8.String -import System.FilePath (()) -import System.Directory (doesFileExist) - -import qualified Data.ByteString as SB -import Snap.Util.FileServe (fileServeSingle) -import Snap.Types (Snap, rqURI, getRequest, writeBS) -import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen - , ConfigListen (..), emptyConfig - ) - -import Hakyll.Web.Util.String (replaceAll) - --- | The first file in the list that actually exists is returned --- -findFile :: [FilePath] -> IO (Maybe FilePath) -findFile [] = return Nothing -findFile (x : xs) = do - exists <- doesFileExist x - if exists then return (Just x) else findFile xs - --- | Serve a given directory --- -static :: FilePath -- ^ Directory to serve - -> (FilePath -> IO ()) -- ^ Pre-serve hook - -> Snap () -static directory preServe = do - -- Obtain the path - uri <- rqURI <$> getRequest - let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? - $ replaceAll "#[^#]*$" (const "") -- Remove #section - $ replaceAll "^/" (const "") -- Remove leading / - $ decode $ SB.unpack uri - - -- Try to find the requested file - r <- liftIO $ findFile $ map (directory ) $ - [ filePath - , filePath "index.htm" - , filePath "index.html" - ] - - case r of - -- Not found, error - Nothing -> writeBS "Not found" - -- Found, serve - Just f -> do - liftIO $ preServe f - fileServeSingle f - --- | 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 = - httpServe config $ static directory preServe - where - -- Snap server config - config = addListen (ListenHttp "0.0.0.0" port) - $ setAccessLog Nothing - $ setErrorLog Nothing - $ emptyConfig diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs new file mode 100644 index 0000000..77b3cb0 --- /dev/null +++ b/src/Hakyll/Web/Preview/Server.hs @@ -0,0 +1,72 @@ +-- | Implements a basic static file server for previewing options +-- +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Web.Preview.Server + ( staticServer + ) where + +import Control.Monad.Trans (liftIO) +import Control.Applicative ((<$>)) +import Codec.Binary.UTF8.String +import System.FilePath (()) +import System.Directory (doesFileExist) + +import qualified Data.ByteString as SB +import Snap.Util.FileServe (serveFile) +import Snap.Types (Snap, rqURI, getRequest, writeBS) +import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen + , ConfigListen (..), emptyConfig + ) + +import Hakyll.Web.Util.String (replaceAll) + +-- | The first file in the list that actually exists is returned +-- +findFile :: [FilePath] -> IO (Maybe FilePath) +findFile [] = return Nothing +findFile (x : xs) = do + exists <- doesFileExist x + if exists then return (Just x) else findFile xs + +-- | Serve a given directory +-- +static :: FilePath -- ^ Directory to serve + -> (FilePath -> IO ()) -- ^ Pre-serve hook + -> Snap () +static directory preServe = do + -- Obtain the path + uri <- rqURI <$> getRequest + let filePath = replaceAll "\\?$" (const "") -- Remove trailing ? + $ replaceAll "#[^#]*$" (const "") -- Remove #section + $ replaceAll "^/" (const "") -- Remove leading / + $ decode $ SB.unpack uri + + -- Try to find the requested file + r <- liftIO $ findFile $ map (directory ) $ + [ filePath + , filePath "index.htm" + , filePath "index.html" + ] + + case r of + -- Not found, error + Nothing -> writeBS "Not found" + -- Found, serve + Just f -> do + liftIO $ preServe f + serveFile f + +-- | 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 = + httpServe config $ static directory preServe + where + -- Snap server config + config = addListen (ListenHttp "0.0.0.0" port) + $ setAccessLog Nothing + $ setErrorLog Nothing + $ emptyConfig -- cgit v1.2.3