Widget.hs

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