Make static server configurable

1 files changed, 26 insertions, 10 deletions

diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs
index 44f2607..0e25959 100644
--- a/src/Hakyll/Network/Server.hs
+++ b/src/Hakyll/Network/Server.hs
@@ -1,6 +1,10 @@
 -- | 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
@@ -8,9 +12,11 @@ import System.FilePath ((</>))
 import System.Directory (doesFileExist)
 
 import qualified Data.ByteString as SB
-import Snap.Util.FileServe
-import Snap.Types
-import Snap.Http.Server
+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)
 
@@ -24,10 +30,10 @@ findFile (x : xs) = do
 
 -- | Serve a given directory
 --
-site :: FilePath             -- ^ Directory to serve
-     -> (FilePath -> IO ())  -- ^ Pre-serve hook
-     -> Snap ()
-site directory preServe = do
+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 ?
@@ -50,7 +56,17 @@ site directory preServe = do
             liftIO $ preServe f
             fileServeSingle f
 
--- | Main method, runs snap
+-- | Main method, runs a static server in the given directory
 --
-main :: IO ()
-main = httpServe defaultConfig $ site "." (\f -> putStrLn $ "Serving " ++ f)
+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