module Happstack.Helpers.DirBrowse
(browsedir, browsedirHS, browsedir')
where
import System.FilePath
import Happstack.Server
import System.Directory (doesDirectoryExist,getDirectoryContents,doesFileExist)
import Data.List (isPrefixOf,sort,intercalate)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char (toLower)
import Language.Haskell.HsColour.HTML
import Language.Haskell.HsColour.Colourise
import Control.Monad
import Control.Monad.Trans
browsedir :: (MonadIO m) => FilePath -> FilePath -> ServerPartT m Response
browsedir = browsedir' defPaintdir defPaintfile
browsedirHS :: (MonadIO m) => FilePath -> FilePath -> ServerPartT m Response
browsedirHS = browsedir' defPaintdir hsPaintfile
browsedir' :: (ToMessage a, ToMessage b, MonadIO m) => (String -> [FilePath] -> a)
-> (String -> String -> b)
-> FilePath
-> FilePath
-> ServerPartT m Response
browsedir' paintdir paintfile diralias syspath = do
rq <- askRq
let aliaspath = ( mypathstring . rqPaths $ rq )
if (not $ isPrefixOf (addTrailingPathSeparator diralias) $ (addTrailingPathSeparator aliaspath) )
then mzero
else do
let realpath = mypathstring $ syspath : (tail $ rqPaths rq)
isDir <- liftIO $ doesDirectoryExist realpath
if isDir
then do
fs <- liftIO $ getDirectoryContents realpath
return . toResponse $ paintdir aliaspath fs
else do
isfile <- liftIO $ doesFileExist realpath
f <- liftIO $ readFile realpath
return . toResponse $ paintfile realpath f
where
mypathstring pathparts =
let sep :: String
sep = [pathSeparator]
in intercalate sep pathparts
hsPaintfile filename f | isHaskellFile = BrowseHtmlString . ( hscolour defaultColourPrefs False False filename ) $ f
| otherwise = BrowseHtmlString f
where
isHaskellFile :: Bool
isHaskellFile =
( (drop (length filename 3) n) ) == ".hs"
|| (drop (length filename 3) n) == ".lhs"
where n = map toLower filename
defaultColourPrefs = ColourPrefs
{ keyword = [Foreground Green,Underscore]
, keyglyph = [Foreground Red]
, layout = [Foreground Cyan]
, comment = [Foreground Blue]
, conid = [Normal]
, varid = [Normal]
, conop = [Foreground Red,Bold]
, varop = [Foreground Cyan]
, string = [Foreground Magenta]
, char = [Foreground Magenta]
, number = [Foreground Magenta]
, cpp = [Foreground Magenta,Dim]
, selection = [Bold, Foreground Magenta]
, variantselection = [Dim, Foreground Red, Underscore]
, definition = [Foreground Blue]
}
defPaintfile _ f = f
defPaintdir aliaspath fs =
let flinks = map g . filter (not . boringfile ) . sort $ fs
g f = simpleLink ('/' : (combine aliaspath f)) f
in BrowseHtmlString $ "<h3>" ++ aliaspath ++ "</h3>\n<ul>" ++ concatMap li flinks ++ "</ul>"
where simpleLink url anchor = "<a href=" ++ url ++ ">" ++ anchor ++ "</a>"
li x = "<li>" ++ x ++ "</li>\n"
boringfile "." = False
boringfile ".." = False
boringfile ('.':_) = True
boringfile ('#':_) = True
boringfile f | last f == '~' || head f == '#' = True
| let e = takeExtension f in e == ".o" || e == ".hi" = True
| otherwise = False
newtype BrowseHtmlString = BrowseHtmlString String
instance ToMessage BrowseHtmlString where
toContentType _ = B.pack "text/html"
toMessage (BrowseHtmlString s) = L.pack s