summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt <jaspervdj@gmail.com>2011-01-17 23:21:20 +0100
committerJasper Van der Jeugt <jaspervdj@gmail.com>2011-01-17 23:21:20 +0100
commitcea21979242b417e5c79662dc2c8a20bb25dc1f1 (patch)
tree371fd712a7affdb584c0c80973e908b287a069f8
parent2f951598efa4bc879bad22c3ae94991fff41694e (diff)
downloadhakyll-cea21979242b417e5c79662dc2c8a20bb25dc1f1.tar.gz
Add prototype preview server
-rw-r--r--src/Hakyll/Network/Server.hs56
1 files changed, 56 insertions, 0 deletions
diff --git a/src/Hakyll/Network/Server.hs b/src/Hakyll/Network/Server.hs
new file mode 100644
index 0000000..44f2607
--- /dev/null
+++ b/src/Hakyll/Network/Server.hs
@@ -0,0 +1,56 @@
+-- | Implements a basic static file server for previewing options
+--
+{-# LANGUAGE OverloadedStrings #-}
+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
+import Snap.Types
+import Snap.Http.Server
+
+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
+--
+site :: FilePath -- ^ Directory to serve
+ -> (FilePath -> IO ()) -- ^ Pre-serve hook
+ -> Snap ()
+site 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 snap
+--
+main :: IO ()
+main = httpServe defaultConfig $ site "." (\f -> putStrLn $ "Serving " ++ f)