@@ -0,0 +1,56 @@
1+-- | Implements a basic static file server for previewing options
2+--
3+{-# LANGUAGE OverloadedStrings #-}
4+import Control.Monad.Trans (liftIO)
5+import Control.Applicative ((<$>))
6+import Codec.Binary.UTF8.String
7+import System.FilePath ((</>))
8+import System.Directory (doesFileExist)
9+
10+import qualified Data.ByteString as SB
11+import Snap.Util.FileServe
12+import Snap.Types
13+import Snap.Http.Server
14+
15+import Hakyll.Web.Util.String (replaceAll)
16+
17+-- | The first file in the list that actually exists is returned
18+--
19+findFile :: [FilePath] -> IO (Maybe FilePath)
20+findFile [] = return Nothing
21+findFile (x : xs) = do
22+ exists <- doesFileExist x
23+ if exists then return (Just x) else findFile xs
24+
25+-- | Serve a given directory
26+--
27+site :: FilePath -- ^ Directory to serve
28+ -> (FilePath -> IO ()) -- ^ Pre-serve hook
29+ -> Snap ()
30+site directory preServe = do
31+ -- Obtain the path
32+ uri <- rqURI <$> getRequest
33+ let filePath = replaceAll "\\?$" (const "") -- Remove trailing ?
34+ $ replaceAll "#[^#]*$" (const "") -- Remove #section
35+ $ replaceAll "^/" (const "") -- Remove leading /
36+ $ decode $ SB.unpack uri
37+
38+ -- Try to find the requested file
39+ r <- liftIO $ findFile $ map (directory </>) $
40+ [ filePath
41+ , filePath </> "index.htm"
42+ , filePath </> "index.html"
43+ ]
44+
45+ case r of
46+ -- Not found, error
47+ Nothing -> writeBS "Not found"
48+ -- Found, serve
49+ Just f -> do
50+ liftIO $ preServe f
51+ fileServeSingle f
52+
53+-- | Main method, runs snap
54+--
55+main :: IO ()
56+main = httpServe defaultConfig $ site "." (\f -> putStrLn $ "Serving " ++ f)