diff options
author | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-01-17 23:21:20 +0100 |
---|---|---|
committer | Jasper Van der Jeugt <jaspervdj@gmail.com> | 2011-01-17 23:21:20 +0100 |
commit | cea21979242b417e5c79662dc2c8a20bb25dc1f1 (patch) | |
tree | 371fd712a7affdb584c0c80973e908b287a069f8 /src | |
parent | 2f951598efa4bc879bad22c3ae94991fff41694e (diff) | |
download | hakyll-cea21979242b417e5c79662dc2c8a20bb25dc1f1.tar.gz |
Add prototype preview server
Diffstat (limited to 'src')
-rw-r--r-- | src/Hakyll/Network/Server.hs | 56 |
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) |