Directory.hs

module Network.Salvia.Handlers.Directory (
    hDirectory
  , hDirectoryResource
  ) where

import Control.Monad.State
import Data.List (sort)
import System.Directory (doesDirectoryExist, getDirectoryContents)

import Network.Salvia.Httpd
import Network.Salvia.Handlers.Redirect
import Network.Salvia.Handlers.File (hResource)
import Network.Protocol.Http
import Network.Protocol.Uri (path, modPath)
import Misc.Misc (bool)

hDirectory :: Handler ()
hDirectory = hResource hDirectoryResource

hDirectoryResource :: ResourceHandler ()
hDirectoryResource dirName = do
  req <- gets request
  if (null $ path $ uri req) || (last $ path $ uri req) /= '/'
   then hRedirect (modPath (++"/") $ uri req)
   else dirHandler dirName

dirHandler:: ResourceHandler ()
dirHandler dirName = do
  req <- gets request
  filenames <- lift $ getDirectoryContents dirName
  processed <- lift $ mapM (processFilename dirName) (sort filenames)
  let b = listing (path $ uri req) processed
  modResponse
    $ setContentType   "text/html" Nothing
    . setContentLength (length b)
    . setStatus OK
  sendStr b

-- Add trailing slash to a directory name.
processFilename :: FilePath -> FilePath -> IO FilePath
processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f)

-- Turn a list of filenames into HTML directory listing.
listing :: FilePath -> [FilePath] -> String
listing dirName fileNames =
  concat [
    "<html><head><title>Index of "
  , dirName
  , "</title></head><body><h1>Index of "
  , dirName
  , "</h1><ul>"
  , fileNames >>= \f -> concat ["<li><a href='", f, "'>", f, "</a></li>"]
  , "</ul></body></html>"
  ]