diff options
Diffstat (limited to 'src/Hakyll/Web')
-rw-r--r-- | src/Hakyll/Web/Preview/Server.hs | 57 |
1 files changed, 14 insertions, 43 deletions
diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs index 4269509..22d48ad 100644 --- a/src/Hakyll/Web/Preview/Server.hs +++ b/src/Hakyll/Web/Preview/Server.hs @@ -6,56 +6,27 @@ module Hakyll.Web.Preview.Server ) where import Control.Monad.Trans (liftIO) -import Control.Applicative ((<$>)) -import Codec.Binary.UTF8.String -import Network.HTTP.Base (urlDecode) -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 Snap.Types (Snap) +import Snap.Util.FileServe ( DirectoryConfig (..), fancyDirectoryConfig + , serveDirectoryWith + ) +import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog + , setPort, emptyConfig ) -import Hakyll.Core.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 / - $ urlDecode $ 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 +static directory preServe = + serveDirectoryWith directoryConfig directory + where + directoryConfig :: DirectoryConfig Snap + directoryConfig = fancyDirectoryConfig + { preServeHook = liftIO . preServe + } -- | Main method, runs a static server in the given directory -- @@ -67,7 +38,7 @@ staticServer directory preServe port = httpServe config $ static directory preServe where -- Snap server config - config = addListen (ListenHttp "0.0.0.0" port) + config = setPort port $ setAccessLog Nothing $ setErrorLog Nothing $ emptyConfig |