Move preview server, update to snap 0.4

1 files changed, 72 insertions, 0 deletions

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