-- | Implements a basic static file server for previewing options
--
{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Web.Preview.Server
    ( staticServer
    ) where

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 (serveFile)
import Snap.Types (Snap, rqURI, getRequest, writeBS)
import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen
                        , ConfigListen (..), emptyConfig
                        )

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
--
static :: FilePath             -- ^ Directory to serve
       -> (FilePath -> IO ())  -- ^ Pre-serve hook
       -> Snap ()
static 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
            serveFile f

-- | Main method, runs a static server in the given directory
--
staticServer :: FilePath             -- ^ Directory to serve
             -> (FilePath -> IO ())  -- ^ Pre-serve hook
             -> Int                  -- ^ Port to listen on
             -> IO ()                -- ^ Blocks forever
staticServer directory preServe port =
    httpServe config $ static directory preServe
  where
    -- Snap server config
    config = addListen (ListenHttp "0.0.0.0" port)
           $ setAccessLog Nothing
           $ setErrorLog Nothing
           $ emptyConfig