From cea21979242b417e5c79662dc2c8a20bb25dc1f1 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Mon, 17 Jan 2011 23:21:20 +0100
Subject: Add prototype preview server

---
 src/Hakyll/Network/Server.hs | 56 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 src/Hakyll/Network/Server.hs

(limited to 'src/Hakyll/Network/Server.hs')

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)
-- 
cgit v1.2.3