blob: 44f26075a8406acc0912ac07994a026bd7de506f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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)
|
