-- FIXME: UTF-8 filenames.
module Text.XHtml.FCKeditor.FileBrowser
       (
         SSIConfig(..), SSIException(..)
       , handleFileBrowser
       ) where

import Control.Exception ( Exception(DynException) )
import Control.Monad ( foldM, unless, when )
import qualified Data.ByteString.Lazy as BS
import Data.Char ( ord, toLower )
import Data.Dynamic ( Typeable, toDyn )
import Data.List ( foldl', sortBy )
import System.Directory ( getDirectoryContents, createDirectory, doesDirectoryExist, doesFileExist )
import System.IO ( IOMode(ReadMode, WriteMode), hClose, hFileSize, openFile )
import System.IO.Error

import Network.CGI ( MonadCGI, MonadIO,
                     getInput, getInputFilename, getInputFPS,
                     liftIO, logCGI, throwCGI )

import Text.XML.HaXml.Combinators ( CFilter, mkElem, mkElemAttr, literal, cdata )
import Text.XML.HaXml.Escape      ( xmlEscape, stdXmlEscaper )
import Text.XML.HaXml.Types       ( Element, Content(..) )
import Text.XML.HaXml.Verbatim    ( verbatim )

----------------------------------------

splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy _ [] = [[]]
splitBy f list = case break f list of
                   (first,[]) -> [first]
                   (first,_:rest) -> first : splitBy f rest

-- | Render XML as a string. FIXME terrible string->word8 hack.
showXML :: CFilter -> (String, BS.ByteString)
showXML xml =
  ("text/xml; charset=utf-8",
   BS.pack (map (fromInteger . toInteger . ord) (verbatim (cfilterToElem xml))))

cfilterToElem :: CFilter -> Element
cfilterToElem f = case f (CString False "") of
                    [CElem e] -> xmlEscape stdXmlEscaper e
                    []        -> error "FIXME RSS produced no output"
                    _         -> error "FIXME RSS produced more than one output"

-- | Verify the path is not dodgy:
--
--  * If it contains \'..\', then ensure it isn't talking about a path
--  * higher than the root.
verifyPath :: FilePath -> Bool
verifyPath p = foldl' countParent 0 (splitBy (== '/') p) >= 0
  where
    countParent acc ".." = acc - (1 :: Int)
    countParent acc _    = acc + 1

----------------------------------------

data SSIConfig =
     SSIConfig
     {
       ssiPathPrefix :: FilePath -- ^ The prefix of the file area on the filesystem.
     , ssiURLPrefix :: FilePath -- ^ The URL prefix from which these files can be reached.
     , ssiCanUpload :: Bool -- ^ Enable the \'Upload\' command.
     }

data SSIConfigI =
     SSIConfigI
     {
       ssiConfig :: SSIConfig
     , ssiCurrentFolder :: FilePath
     , ssiType :: String
     }

-- | Assemble the current directory on the filesystem from the user
-- configuration and the request. Verify that the request path is not
-- suspect, but trust the configuration path.
assembleDir :: MonadCGI m => SSIConfigI -> m FilePath
assembleDir config =
  do unless (verifyPath (ssiCurrentFolder config)) $
       error "FIXME exception"
     return $ ssiPathPrefix (ssiConfig config) ++ "/" ++ ssiCurrentFolder config ++ "/" -- FIXME '/'

-- | As most errors are unrecoverable, 'handleFileBrowser' throws
-- fairly opaque exceptions using @CGI.throwCGI@.
newtype SSIException = SSIException String
        deriving ( Typeable )

-- | Responds to requests from FCKeditor's file browser. Returns the
-- @content-type@ and a @ByteString@-encoded XML document that should
-- be sent back to the webserver. Throws exceptions using
-- @CGI.throwCGI@. The caller needs to take care of the HTTP
-- @cache-control@ header.
handleFileBrowser :: (MonadCGI m, MonadIO m)
                  => SSIConfig
                  -> m (String, BS.ByteString)
handleFileBrowser config =
  do fbc  <- getInput "Command"
     fbt  <- getInput "Type"
     fbcf <- getInput "CurrentFolder"
     case (fbc, fbt, fbcf) of
       (Just fbCommand, Just fbType, Just fbCurrentFolder) ->
         do let configI = SSIConfigI
                          { ssiConfig = config
                          , ssiCurrentFolder = fbCurrentFolder
                          , ssiType = fbType }
            case fbCommand of
              "GetFolders"         -> getFolders configI
              "GetFoldersAndFiles" -> getFoldersAndFiles configI
              "CreateFolder"       -> createFolder configI
              "FileUpload" | ssiCanUpload config
                                   -> fileUpload configI
              _                    -> throwCGI $ DynException $ toDyn $ SSIException "handleFileBrowser: unknown command."
       _ -> throwCGI $ DynException $ toDyn $ SSIException "handleFileBrowser: missing parameters."

getFolders :: (MonadCGI m, MonadIO m) => SSIConfigI -> m (String, BS.ByteString)
getFolders config =
  do (folders, _files) <- splitIntoFoldersAndFiles config
     return (showXML (xmlFileList config "GetFolders" (folders, [])))

getFoldersAndFiles :: (MonadCGI m, MonadIO m) => SSIConfigI -> m (String, BS.ByteString)
getFoldersAndFiles config =
  splitIntoFoldersAndFiles config
    >>= return . showXML . xmlFileList config "GetFoldersAndFiles"

splitIntoFoldersAndFiles :: (MonadCGI m, MonadIO m)
                         => SSIConfigI -> m ([FilePath], [(FilePath, Integer)])
splitIntoFoldersAndFiles config =
  do dir <- assembleDir config
     liftIO $ getDirectoryContents dir
                >>= return . sortBy reverseCaseInsensitive
                  >>= foldM (split dir) ([], [])
  where
    reverseCaseInsensitive s s' =
      case compare (map toLower s) (map toLower s') of
        LT -> GT
        EQ -> EQ
        GT -> LT

    split dir ff@(folders, files) f =
      if f == "." || f == ".." -- FIXME skip special dirs
        then return ff
        else
          do let dirf = dir ++ f
             b <- doesDirectoryExist dirf
             if b
               then return (f:folders, files)
               else
                 do h <- openFile dirf ReadMode
                    size <- hFileSize h
                    hClose h
                    return (folders, (f, size):files)

-- FIXME perhaps abstract the path assembling here.
xmlFileList :: SSIConfigI -> String -> ([FilePath], [(FilePath, Integer)]) -> CFilter
xmlFileList config fbCommand (folders, files) =
    mkElemAttr "Connector"
      [ ("command",      literal fbCommand)
      , ("resourceType", literal (ssiType config))
      ]
        ([ mkElemAttr "CurrentFolder"
             [ ("path", literal (ssiCurrentFolder config))
             , ("url",  literal (ssiURLPrefix (ssiConfig config) ++ ssiCurrentFolder config))
             ]
               []
         ] ++ foldersElem ++ filesElem)
  where
    foldersChildren = [ mkElemAttr "Folder" [("name", literal f)] [] | f <- folders ]
    foldersElem = case foldersChildren of
                    [] -> []
                    _  -> [mkElem "Folders" foldersChildren]

    -- NOTE: FCKeditor wants size in kb
    filesChildren = [ mkElemAttr "File" [("name", literal f),
                                         ("size", literal (show (size `div` 1024)))] []
                      | (f, size) <- files ]
    filesElem = case filesChildren of
                  [] -> []
                  _  -> [mkElem "Files" filesChildren]

----------------------------------------

createFolder :: (MonadIO m, MonadCGI m) => SSIConfigI -> m (String, BS.ByteString)
createFolder config =
  do when (ssiType config == "File") $ fail "FIXME createFolder expected Type == File"
     Just fbNewFolderName <- getInput "NewFolderName" -- FIXME
     dirf <- assembleDir config >>= return . (++ fbNewFolderName)
     liftIO (try (createDirectory dirf))
       >>= createFolder_error
         >>= return . showXML . xmlCreateFolderResponse config

createFolder_error :: (MonadIO m, MonadCGI m) => Either IOError () -> m Int
createFolder_error (Right ()) = return 0 -- createFolder_noError
createFolder_error (Left e)   =
  do logCGI $ "FCKeditor.FileBrowser.createFolder: " ++ show e
     let errorCode | isAlreadyExistsError e = 101
--                   | isInvalidFolderName  e = 102 -- FIXME
                   | isPermissionError    e = 103
                   | otherwise              = 110
     return errorCode

-- FIXME perhaps abstract the path assembling here.
xmlCreateFolderResponse :: SSIConfigI -> Int -> CFilter
xmlCreateFolderResponse config errorCode =
    mkElemAttr "Connector"
      [ ("command",      literal "CreateFolder")
      , ("resourceType", literal "File")
      ]
        [ mkElemAttr "CurrentFolder"
            [ ("path", literal (ssiPathPrefix (ssiConfig config) ++ ssiCurrentFolder config))
            , ("url",  literal (ssiURLPrefix  (ssiConfig config) ++ ssiCurrentFolder config))
            ]
              []
        , mkElemAttr "Error"
            [ ("number", literal (show errorCode)) ]
              []
        ]

----------------------------------------

-- | FIXME Argh, this is racey. Also if they upload text we're a bit
-- screwed. Probably should check the input encoding.
-- Check the filetype being uploaded (extension, MIME type) against a list
-- of allowed types. Limit maximum upload size. Use a temp file + move?
fileUpload :: (MonadIO m, MonadCGI m) => SSIConfigI -> m (String, BS.ByteString)
fileUpload config =
  do mFileName <- getInputFilename "NewFile"
     case mFileName of
       Nothing -> throwCGI $ DynException $ toDyn "FIXME fileUpload don't know the filename"
       Just filename ->
         do let fbits = splitBy (== '.') filename
                base = concat (init fbits)
                ext = last fbits
            saveFile config base ext 0
              >>= fileUpload_error config
                >>= return . htmlFileUpload

saveFile :: (MonadIO m, MonadCGI m) => SSIConfigI -> String -> String -> Int -> m (Either IOError (String, Bool))
saveFile config base ext x =
  do let fname = base
                   ++ (if x == 0 then "" else "(" ++ show x ++ ")")
                   ++ (if null ext then "" else '.':ext)
     dirf <- assembleDir config >>= (return . (++ fname))
     b <- liftIO (doesFileExist dirf)
     if b
       then saveFile config base ext (x + 1)
       else
         do mInput <- getInputFPS "NewFile"
            case mInput of
              Nothing    -> throwCGI $ DynException $ toDyn "FIXME fileUpload no input called NewFile"
              Just input ->
                liftIO $ try $
                  do h <- openFile dirf WriteMode
                     BS.hPut h input
                     hClose h
                     return ( ssiCurrentFolder config ++ "/" ++ fname
                            , x /= 0) -- FIXME is this path right?

fileUpload_error :: (MonadIO m, MonadCGI m)
                 => SSIConfigI
                 -> Either IOError (String, Bool)
                 -> m (Int, String, FilePath, String)
fileUpload_error config (Right (fname, changed)) =
     return ( if changed then 201 else 0
            , ssiURLPrefix (ssiConfig config) ++ fname
            , fname
            , "")
fileUpload_error _config (Left e) =
  do logCGI $ "FCKeditor.FileBrowser.fileUpload: " ++ show e
     return (1, "", "", show e) -- FIXME 

-- FIXME terrible string->bs hack.
-- FIXME what's this URL parameter for?
-- FIXME get the error handling right
htmlFileUpload :: (Int, String, FilePath, String) -> (String, BS.ByteString)
htmlFileUpload (errorCode, url, fname, reason) =
    ("text/html; charset=utf-8",
     BS.pack (map (fromInteger . toInteger . ord) (verbatim (cfilterToElem xml))))
  where
    xml =
      mkElemAttr
        "script"
        [ ("type", literal "text/javascript") ]
        [ cdata $ "window.parent.OnUploadCompleted( " ++ args ++ " ) ;" ]
    args = show errorCode ++ ",'" ++ url ++ "','" ++ fname ++ "','" ++ reason ++ "'"
--     args | errorCode == 0 = "0" -- no errors found on the upload process.
--          | errorCode == 1 = "1,,,'" ++ reason ++ "'" -- the upload filed because of "Reason".
--          | errorCode == 201 = "201,, '" ++ fname ++ "'" -- the file has been uploaded successfully, but its name has been changed to "fname".
--          | otherwise = "202" -- invalid file. 


{-

# upload Content-Type list
my %UPLOAD_CONTENT_TYPE_LIST = (
	'image/(x-)?png'						=>	'png',	# PNG image
	'image/p?jpe?g'							=>	'jpg',	# JPEG image
	'image/gif'								=>	'gif',	# GIF image
	'image/x-xbitmap'						=>	'xbm',	# XBM image

	'image/(x-(MS-)?)?bmp'					=>	'bmp',	# Windows BMP image
	'image/pict'							=>	'pict',	# Macintosh PICT image
	'image/tiff'							=>	'tif',	# TIFF image
	'application/pdf'						=>	'pdf',	# PDF image
	'application/x-shockwave-flash'			=>	'swf',	# Shockwave Flash

	'video/(x-)?msvideo'					=>	'avi',	# Microsoft Video
	'video/quicktime'						=>	'mov',	# QuickTime Video
	'video/mpeg'							=>	'mpeg',	# MPEG Video
	'video/x-mpeg2'							=>	'mpv2', # MPEG2 Video

	'audio/(x-)?midi?'						=>	'mid',	# MIDI Audio
	'audio/(x-)?wav'						=>	'wav',	# WAV Audio
	'audio/basic'							=>	'au',	# ULAW Audio
	'audio/mpeg'							=>	'mpga',	# MPEG Audio

	'application/(x-)?zip(-compressed)?'	=>	'zip',	# ZIP Compress

	'text/html'								=>	'html', # HTML
	'text/plain'							=>	'txt',	# TEXT
	'(?:application|text)/(?:rtf|richtext)'	=>	'rtf',	# RichText

	'application/msword'					=>	'doc',	# Microsoft Word
	'application/vnd.ms-excel'				=>	'xls',	# Microsoft Excel

	''
);

# Upload is permitted.
# A regular expression is possible.
my %UPLOAD_EXT_LIST = (
	'png'					=>	'PNG image',
	'p?jpe?g|jpe|jfif|pjp'	=>	'JPEG image',
	'gif'					=>	'GIF image',
	'xbm'					=>	'XBM image',

	'bmp|dib|rle'			=>	'Windows BMP image',
	'pi?ct'					=>	'Macintosh PICT image',
	'tiff?'					=>	'TIFF image',
	'pdf'					=>	'PDF image',
	'swf'					=>	'Shockwave Flash',

	'avi'					=>	'Microsoft Video',
	'moo?v|qt'				=>	'QuickTime Video',
	'm(p(e?gv?|e|v)|1v)'	=>	'MPEG Video',
	'mp(v2|2v)'				=>	'MPEG2 Video',

	'midi?|kar|smf|rmi|mff'	=>	'MIDI Audio',
	'wav'					=>	'WAVE Audio',
	'au|snd'				=>	'ULAW Audio',
	'mp(e?ga|2|a|3)|abs'	=>	'MPEG Audio',

	'zip'					=>	'ZIP Compress',
	'lzh'					=>	'LZH Compress',
	'cab'					=>	'CAB Compress',

	'd?html?'				=>	'HTML',
	'rtf|rtx'				=>	'RichText',
	'txt|text'				=>	'Text',

	''
);

-}