git.iko.soy/hakyll
on f104f91 help sign in
hakyll/src/Hakyll/Network/Server.hs
72 lines 2.4 kB history raw
1-- | Implements a basic static file server for previewing options
2--
3{-# LANGUAGE OverloadedStrings #-}
4module Hakyll.Network.Server
5 ( staticServer
6 ) where
8import Control.Monad.Trans (liftIO)
9import Control.Applicative ((<$>))
10import Codec.Binary.UTF8.String
11import System.FilePath ((</>))
12import System.Directory (doesFileExist)
14import qualified Data.ByteString as SB
15import Snap.Util.FileServe (fileServeSingle)
16import Snap.Types (Snap, rqURI, getRequest, writeBS)
17import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen
18 , ConfigListen (..), emptyConfig
19 )
21import Hakyll.Web.Util.String (replaceAll)
23-- | The first file in the list that actually exists is returned
24--
25findFile :: [FilePath] -> IO (Maybe FilePath)
26findFile [] = return Nothing
27findFile (x : xs) = do
28 exists <- doesFileExist x
29 if exists then return (Just x) else findFile xs
31-- | Serve a given directory
32--
33static :: FilePath -- ^ Directory to serve
34 -> (FilePath -> IO ()) -- ^ Pre-serve hook
35 -> Snap ()
36static directory preServe = do
37 -- Obtain the path
38 uri <- rqURI <$> getRequest
39 let filePath = replaceAll "\\?$" (const "") -- Remove trailing ?
40 $ replaceAll "#[^#]*$" (const "") -- Remove #section
41 $ replaceAll "^/" (const "") -- Remove leading /
42 $ decode $ SB.unpack uri
44 -- Try to find the requested file
45 r <- liftIO $ findFile $ map (directory </>) $
46 [ filePath
47 , filePath </> "index.htm"
48 , filePath </> "index.html"
49 ]
51 case r of
52 -- Not found, error
53 Nothing -> writeBS "Not found"
54 -- Found, serve
55 Just f -> do
56 liftIO $ preServe f
57 fileServeSingle f
59-- | Main method, runs a static server in the given directory
60--
61staticServer :: FilePath -- ^ Directory to serve
62 -> (FilePath -> IO ()) -- ^ Pre-serve hook
63 -> Int -- ^ Port to listen on
64 -> IO () -- ^ Blocks forever
65staticServer directory preServe port =
66 httpServe config $ static directory preServe
67 where
68 -- Snap server config
69 config = addListen (ListenHttp "0.0.0.0" port)
70 $ setAccessLog Nothing
71 $ setErrorLog Nothing
72 $ emptyConfig