fckeditor (empty) → 0.1
raw patch · 7 files changed
+706/−0 lines, 7 filesdep +HaXmldep +basedep +cgisetup-changed
Dependencies added: HaXml, base, cgi, xhtml
Files
- LICENSE +26/−0
- Setup.lhs +6/−0
- Text/XHtml/FCKeditor.hs +14/−0
- Text/XHtml/FCKeditor/FileBrowser.hs +364/−0
- Text/XHtml/FCKeditor/Validate.hs +83/−0
- Text/XHtml/FCKeditor/Widget.hs +189/−0
- fckeditor.cabal +24/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2007-2008, Peter Gammie <peteg42 at gmail dot com>+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.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runghc++> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain
+ Text/XHtml/FCKeditor.hs view
@@ -0,0 +1,14 @@+-- | \"Server side integration\" for FCKeditor <http://www.fckeditor.net/>.+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
+ Text/XHtml/FCKeditor/FileBrowser.hs view
@@ -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',++ ''+);++-}
+ Text/XHtml/FCKeditor/Validate.hs view
@@ -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 @\<div\>@ 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' = "<div>" ++ contents ++ "</div>"++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 \<embed\> into \<object\>.+fixup :: CFilter+fixup = foldXml (tag "embed" ?> replaceTag "object" :> keep)++{-++What we get:++<embed type="application/x-shockwave-flash"+ pluginspage="http://www.macromedia.com/go/getflashplayer"+ src="http://www.youtube.com/v/iUjFNJeWJ2s" width="425" height="355"+ play="true" loop="true" menu="true" />++What we want:++<object width="425" height="355"><param name="movie"+value="http://www.youtube.com/v/iUjFNJeWJ2s&rel=1"></param><param+name="wmode" value="transparent"></param></object>++-}
+ Text/XHtml/FCKeditor/Widget.hs view
@@ -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 @\<div\>@.+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 $+ [+ "<!--"+-- , "initFunctions.push(function () { });"+ , "var oFCKeditor = new FCKeditor( '" ++ ewName ec ++ "' ) ;"+ , "oFCKeditor.BasePath = '" ++ ewScriptBase ec ++ "/fckeditor/';"+ , "oFCKeditor.Height = " ++ show (ewHeight ec) ++ " ;"+ , "oFCKeditor.Width = " ++ show (ewWidth ec) ++ " ;"+ , "oFCKeditor.Value = '" ++ escapeJS (ewInitial ec) ++ "' ;"+ , "oFCKeditor.Config[\"DocType\"] = '" ++ escapeJS "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" ++ "' ;"+ ]+ ++ case ewLanguage ec of+ Nothing -> []+ Just l ->+ [ "oFCKeditor.Config[\"AutoDetectLanguage\"] = false ;"+ , "oFCKeditor.Config[\"DefaultLanguage\"] = '" ++ l ++ "' ;" ]+ ++ [ "oFCKeditor.Create() ;"+ , "//-->" ]++-- | 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.+-- <http://commons.apache.org/lang/api/overview-summary.html>+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
+ fckeditor.cabal view
@@ -0,0 +1,24 @@+Name: fckeditor+Version: 0.1+License: BSD3+License-file: LICENSE+Author: Peter Gammie <peteg42@gmail.com>+Maintainer: Peter Gammie <peteg42@gmail.com>+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