diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2007-2008, Peter Gammie +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/env runghc + +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/Text/XHtml/FCKeditor.hs b/Text/XHtml/FCKeditor.hs new file mode 100644 --- /dev/null +++ b/Text/XHtml/FCKeditor.hs @@ -0,0 +1,14 @@ +-- | \"Server side integration\" for FCKeditor . +module Text.XHtml.FCKeditor + ( + -- * Handle file browser requests. + module Text.XHtml.FCKeditor.FileBrowser + -- * Validate user input against XHTML 1.0 Strict. + , module Text.XHtml.FCKeditor.Validate + -- * Generate XHTML for editor inclusion FIXME. + , module Text.XHtml.FCKeditor.Widget + ) where + +import Text.XHtml.FCKeditor.FileBrowser +import Text.XHtml.FCKeditor.Validate +import Text.XHtml.FCKeditor.Widget diff --git a/Text/XHtml/FCKeditor/FileBrowser.hs b/Text/XHtml/FCKeditor/FileBrowser.hs new file mode 100644 --- /dev/null +++ b/Text/XHtml/FCKeditor/FileBrowser.hs @@ -0,0 +1,364 @@ +-- 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', + + '' +); + +-} diff --git a/Text/XHtml/FCKeditor/Validate.hs b/Text/XHtml/FCKeditor/Validate.hs new file mode 100644 --- /dev/null +++ b/Text/XHtml/FCKeditor/Validate.hs @@ -0,0 +1,83 @@ +module Text.XHtml.FCKeditor.Validate + ( + validate + , fixup + ) where + +-- FIXME or should this be MTL? +import Network.CGI ( MonadIO, liftIO ) +import Text.PrettyPrint.HughesPJ + +import Text.XML.HaXml.Combinators +import Text.XML.HaXml.Parse ( xmlParse', dtdParse ) +import Text.XML.HaXml.Pretty ( document, content ) +import Text.XML.HaXml.Types ( Document(..), Content(CElem), Element(Elem) ) +import Text.XML.HaXml.Validate ( partialValidate ) + +-- | Validate against the XHTML 1.0 Strict DTD using HaXML. +-- +-- * If the given DTD relies on other files, then they must be in +-- the current directory of the process (a HaXML limitation). +-- +-- * Wraps the contents in a @\@ in case there are several +-- tags. (HaXML assumes it is going to validate a single tree, not +-- a forest.) This influences errors but not the returned +-- Doc. Implies we can't validate a complete document (one with +-- head, body, etc.). +-- +-- FIXME get the error handling right. @partialValidate@ likes to call "error", +-- so fix that. +-- If the lexer fails than "error" is called. +validate :: (MonadIO m) + => FilePath -- ^ Filename of the DTD. + -> String -- ^ "filename", for errors. + -> String -- ^ Content to be validated. + -> CFilter -- ^ Apply this filter to the content before validating. + -> m (Doc, [String]) +validate xhtmlDTDf filename contents f = + do xhtmlDTD <- liftIO $ readFile xhtmlDTDf + case dtdParse "xhtml1" xhtmlDTD of + Nothing -> fail $ "Parsing XHTML DTD failed." + Just dtd -> + case xmlParse' filename contents' of + Left str -> return (text contents, [str]) + Right doc -> + case onContent f doc of + Left str -> return (document doc, [str]) + -- Remove the div in the returned document. + -- We trust the content filter has not changed it. + Right (Document _ _ elt@(Elem "div" [] cs) _) -> + return (vcat (map content cs), partialValidate dtd elt) + where + -- FIXME would like to do this more nicely... + contents' = "
" ++ contents ++ "
" + +onContent :: CFilter -> Document -> Either String Document +onContent f (Document p s e m) = + case f (CElem e) of + [CElem e'] -> Right (Document p s e' m) + [] -> Left "FIXME filter produced no output" + _ -> Left "FIXME filter produced more than one output" + +-- | FIXME Munge some FCKeditor 2.5 non-XHtml infelicities. +-- +-- * Turn \ into \. +fixup :: CFilter +fixup = foldXml (tag "embed" ?> replaceTag "object" :> keep) + +{- + +What we get: + + + +What we want: + + + +-} diff --git a/Text/XHtml/FCKeditor/Widget.hs b/Text/XHtml/FCKeditor/Widget.hs new file mode 100644 --- /dev/null +++ b/Text/XHtml/FCKeditor/Widget.hs @@ -0,0 +1,189 @@ +module Text.XHtml.FCKeditor.Widget + ( + EditorConfig(..) + , ToolBar(..) + , editorWidget + , htmlTextArea + , fckEditorWidget + , fckEditorWidgetIE + ) where + +import Data.Char ( isAscii ) +import Data.List ( isPrefixOf ) +import Network.CGI ( MonadCGI, getVar ) +import Text.Printf +import Text.XHtml.Strict + +data ToolBar = Default | Basic | Custom String + +showToolBar :: ToolBar -> String +showToolBar tb = + case tb of + Default -> "Default" + Basic -> "Basic" + Custom str -> str + +data EditorConfig = + EditorConfig + { ewScriptBase :: String -- ^ Location of FCKeditor relative to the @base href@ of the page. + , ewName :: String -- ^ The HTML @name@ of the editor widget. + , ewLanguage :: Maybe String -- ^ Specify a two-letter language code or let FCKeditor automatically discover the user's language. + , ewTARows :: Int -- ^ The number of rows in the text area. + , ewTACols :: Int -- ^ The number of columns in the text area. + , ewHeight :: Int -- ^ The height of the FCKeditor instance, in pixels. + , ewWidth :: Int -- ^ The width of the FCKeditor instance, in pixels. + , ewInitial :: String -- ^ Initial contents of the editor widget. + , ewToolBar :: ToolBar -- ^ Which toolbar to use. + } + +-- | Cheap and cheerful version extraction functions. We might like +-- to use regexps, but that story is overcomplex in Haskell. +-- @HTTP_USER_AGENT@ strings tend to be short, so efficiency is not a +-- big deal (FIXME verify this claim). + +-- FIXME inefficent, but easily replaced. +findAndDrop :: String -> String -> String +findAndDrop _pat "" = "" +findAndDrop pat str = + if pat `isPrefixOf` str + then drop (length pat) str + else findAndDrop pat (tail str) + +-- FIXME this is bad. +-- returns e.g. "7.0" +ieVersion :: String -> String +ieVersion ua = + case findAndDrop "MSIE" ua of + "" -> "" + str -> if findAndDrop "mac" ua == "" && findAndDrop "Opera" ua == "" -- FIXME verify. + then take 3 (tail str) + else "" + +-- ua `iM` "MSIE" && not (ua `iM` "mac") && not (ua `iM` "Opera") +-- && True -- (ua =~ "/MSIE/" + 5, take 3) >= 5.5 -- FIXME what does the version comparison mean? + +-- returns e.g. "20071025" +geckoVersion :: String -> String +geckoVersion = take 8 . findAndDrop "Gecko/" + +-- returns e.g. "9.5" +operaVersion :: String -> String +operaVersion = take 4 . findAndDrop "Opera/" + +-- returns e.g. "522" +safariVersion :: String -> String +safariVersion = take 3 . findAndDrop "AppleWebKit/" + +-- | Create an instance of FCKeditor. Determines if the user's browser +-- is likely to be compatible by examining the @HTTP_USER_AGENT@ +-- string, and outputs either an FCKeditor instance if so, and an +-- XHTML @textarea@ if not. +-- +-- Infelicities \/ gotchas: +-- +-- * Creates an @IFRAME@ if @HTTP_USER_AGENT@ indicates the browser +-- is a compatible version of Microsoft Internet Explorer +-- (n.b. @IFRAME@ is not an XHTML 1.0 Strict element). +-- +-- * FIXME currently always uses the @IFRAME@ hack to fix some layout +-- issues further up the pipeline. +-- +-- * Assumes the initial contents of the editor widget are valid +-- XHTML, and performs the necessary JavaScript escaping. +-- +-- * Always places the editor widget into a @\@. +editorWidget :: MonadCGI m => EditorConfig -> m Html +editorWidget ec = +-- A transliteration of the Perl code. + do mUserAgent <- getVar "HTTP_USER_AGENT" + return $ thediv << case mUserAgent of + Nothing -> htmlTextArea ec + Just ua + | ieCompat ua -> fckEditorWidgetIE ec + | geckoCompat ua -> fckEditorWidgetIE ec + | safariCompat ua -> fckEditorWidgetIE ec + | operaCompat ua -> fckEditorWidgetIE ec + | otherwise -> htmlTextArea ec + where + ieCompat ua = ieVersion ua >= "5.5" + geckoCompat ua = geckoVersion ua >= "20030210" + operaCompat ua = operaVersion ua >= "9.5" +-- $iVersion = substr($sAgent,index($sAgent,'Opera/') + 6,4); +-- return($iVersion >= 9.5) ; + safariCompat ua = safariVersion ua >= "522" + +-- | Creates a HTML text area using the given configuration. +htmlTextArea :: EditorConfig -> [Html] +htmlTextArea ec = + [textarea ! [ name (ewName ec) + , rows (show (ewTARows ec)) + , cols (show (ewTACols ec))] << ewInitial ec] + +-- | FIXME document FIXME hardwire some options here. +-- +-- * FIXME loads the JS here. if there are several FCK's on the one +-- page, this may be not good. +fckEditorWidget :: EditorConfig -> [Html] +fckEditorWidget ec = + [ script ! [thetype "text/javascript", src (ewScriptBase ec ++ "/fckeditor/fckeditor.js")] << noHtml + , script ! [thetype "text/javascript"] << primHtml fckEditorScript + ] + where + -- FIXME not very abstract - try to generalise the stuff in Module.hs + fckEditorScript = unlines $ + [ + "" ] + +-- | FIXME document + -- FIXME hardwire some options here. Add the other options to the config string. +fckEditorWidgetIE :: EditorConfig -> [Html] +fckEditorWidgetIE ec = + [ hidden (ewName ec) (ewInitial ec) ! [thestyle "display:none"] + , hidden (ewName ec ++ "___Config") configString + ! [thestyle "display:none"] + , tag "iframe" noHtml + ! [ identifier (ewName ec ++ "___Frame") + , src $ ewScriptBase ec ++ "/fckeditor/editor/fckeditor.html?InstanceName=" ++ ewName ec + ++ "&Toolbar=" ++ showToolBar (ewToolBar ec) + , width "100%" + , height "200" + , strAttr "frameborder" "no" + , strAttr "scrolling" "no" + ] + ] + where + configString = "" -- FIXME + +-- | Turn a Haskell Unicode string into something that JavaScript won't +-- choke on. Loosely based on the Apache Commons Lang library. +-- +escapeJS :: String -> String +escapeJS = concat . map escapeChar + where + escapeChar c = + case c of + '\b' -> "\\b" + '\f' -> "\\f" + '\n' -> "\\n" + '\r' -> "\\r" + '\t' -> "\\t" + '\\' -> "\\\\" + '\'' -> "\\'" + '"' -> "\\\"" + _ | isAscii c -> [c] -- FIXME probably should restrict this a bit more. + | otherwise -> "\\u" ++ printf "%04x" c diff --git a/fckeditor.cabal b/fckeditor.cabal new file mode 100644 --- /dev/null +++ b/fckeditor.cabal @@ -0,0 +1,24 @@ +Name: fckeditor +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Peter Gammie +Maintainer: Peter Gammie +Homepage: http://peteg.org/ +Category: Web +Synopsis: Server-Side Integration for FCKeditor +Description: Provides Server-Side Integration for FCKeditor. +Build-type: Simple +Build-depends: + base, + cgi >= 3001.1.0, + HaXml >=1.13 && <1.14, + xhtml >= 3000.0.1 +Exposed-Modules: + Text.XHtml.FCKeditor +Other-modules: + Text.XHtml.FCKeditor.FileBrowser + Text.XHtml.FCKeditor.Validate + Text.XHtml.FCKeditor.Widget +Extensions: GeneralizedNewtypeDeriving +Ghc-options: -Wall