{-# LANGUAGE NoMonomorphismRestriction #-}

{- | 
  Directory browsing for HAppS

  browsedir \"someDirectory\"
-}
module HAppS.Helpers.DirBrowse 
  (browsedir, browsedirHS, browsedir')
where

import System.FilePath

import HAppS.Server 
import Control.Monad.Trans (liftIO)
import System.Directory (doesDirectoryExist,getDirectoryContents,doesFileExist)
import System.FilePath (combine,takeExtension,pathSeparator)
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 

{- | 
  browsedir = browsedir' defPaintdir defPaintfile 

  define a ServerPartT value with something like

  sp = browsedir \"projectroot\" \".\"  

  where projectroot is an alias (what you see in the url) and "." is the path relative to the executable running 
  
  the happs server

-}
browsedir :: FilePath -> FilePath -> ServerPartT IO Response
browsedir = browsedir' defPaintdir defPaintfile 

{- | 
  like browsedir, but haskell files are rendered through hscolour

  browsedirHS = browsedir' defPaintdir hsPaintfile
-}
browsedirHS :: FilePath -> FilePath -> ServerPartT IO Response
browsedirHS = browsedir' defPaintdir hsPaintfile

{- |
  browsedir' paintdir paintfile diralias syspath

  paintdir/paintfile are rendering functions

  diralias: path that will appear in browser

  syspath: real system path 
-}
browsedir' :: (ToMessage a, ToMessage b) => (String -> [FilePath] -> a)
              -> (String -> String -> b)
              -> FilePath
              -> FilePath
              -> ServerPartT IO Response
browsedir' paintdir paintfile diralias syspath = multi [
  ServerPartT $ \rq -> do
    let aliaspath = ( mypathstring . rqPaths $ rq )
    if (not $ isPrefixOf (addTrailingPathSeparator diralias) $ (addTrailingPathSeparator aliaspath) )
       then noHandle
       else do
         -- to do: s/rqp/realpath/
         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 
    -- Windows/Unix/Mac compatible 
    mypathstring pathparts =
      let sep :: String
          sep = [pathSeparator] 
      in intercalate sep pathparts

hsPaintfile filename f | isHaskellFile filename = BrowseHtmlString . ( hscolour defaultColourPrefs False False f ) $ f
                       | otherwise = BrowseHtmlString f
  where 
    isHaskellFile :: FilePath -> Bool
    isHaskellFile filename =
      ( (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 ('.':xs) = True
boringfile ('#':xs) = True        
boringfile f | last f == '~' || head f == '#' = True
             | let e = takeExtension f in e == ".o" || e == ".hi" = True
             | otherwise = False







{-
-- eg: browsedirWith (ifHaskellFile [withRequest colorize]) "src"  
browsedirWith sp alias d = multi [
    sp
    , browsedir alias d
  ]
-}

newtype BrowseHtmlString = BrowseHtmlString String
instance ToMessage BrowseHtmlString where
  toContentType _ = B.pack "text/html"
  toMessage (BrowseHtmlString s) = L.pack s