-- Gitit plugin to support integration with CodeMirror (in-browser text editor -- with syntax highlighting. -- -- The plugin converts a code block like this: -- -- ~~~ {.codemirror attributes} -- initial contents for a new file -- ~~~ -- into embedded frame of CodeMirror where the file named in the attributes -- may be edited (highlighting type is also specified via attributes). -- -- Logic of this plugin is based on the logic of the "editPage" handler. {-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} module CodeMirror (plugin) where import Prelude hiding (catch) import Network.Gitit.Interface import Text.XHtml hiding (height) import Data.List import Data.Maybe import Text.JSON import Text.JSON.Generic import Data.FileStore import Control.Monad import Control.Monad.Error import System.Exit import System.Process import System.FilePath import System.IO.Error (ioeGetErrorString) import Control.Exception (throwIO, catch, try) import Data.ByteString.Lazy.UTF8 (toString) import Happstack.Server.HTTP.Types plugin :: Plugin plugin = mkPageTransformM transformBlock transformBlock (CodeBlock (_, classes, namevals) contents) | "codemirror" `elem` classes = do doNotCache req <- askRequest mbu <- askUser cfg <- askConfig fs <- askFileStore let inps = rqInputs req nullNth (Just x) | null x = Nothing nullNth mb = mb notnull = not . null -- HTTP request parameters: -- file: path to file (always relative to Wiki root) edited/updated -- revert: revision of the file desired; if missing or blank then the latest revision is used -- latest: latest revision of the file if known (update only) -- editedText: file contents (update only) -- logMsg: VCS log message -- cm_update: "Save" for update request, "Discard" to retrieve the latest revision stored -- or discard the new file contents parmap = zip (map fst inps) (map (toString . inputValue . snd) inps) mbfile = nullNth $ lookup "file" parmap mbrevn = nullNth $ lookup "revert" parmap mbrvto = nullNth $ lookup "revertTo" parmap mblatrev = nullNth $ lookup "latest" parmap mbtext = nullNth $ lookup "editedText" parmap mblogmg = nullNth $ lookup "logMsg" parmap update = lookup "cm_update" parmap == Just "Save" cancel = lookup "cm_update" parmap == Just "Discard" -- Plugin configuration parameters: -- anonpath: path prefix of the area where anonymous users are allowed to edit files. anonpath = nullNth $ lookup "anonpath" namevals -- Who makes the change: user name if logged in or anonymous with their IP address. author = case mbu of Just u -> uUsername u Nothing -> "Anonymous@" ++ show (rqPeer req) -- In certain situations editor cannot be opened, and an error will be thrown. -- The error handler will display the message string. catchError (do -- Check if a file is protected by the config settings. when (isJust mbfile && fromJust mbfile `elem` (map (++ ".page") (noEdit cfg))) $ fail $ "File " ++ fromJust mbfile ++ " is protected from editing" -- Check if the user is logged in or there is anonymous editing area configured. when (isNothing mbu && isNothing anonpath) $ fail "User is not logged in and anonymous editing area is not defined" -- Check if there is anonymous editing area configured, does the name entered -- have the area path as prefix. when (isNothing mbu && isJust anonpath && isJust mbfile && not (fromJust (liftM2 isPrefixOf anonpath mbfile))) $ fail $ "Anonymous users cannot edit this file: " ++ fromJust mbfile -- Fill the log message with default message from the config, if empty. let revto = case mbrvto of Nothing -> "" Just revn -> "(Reverted to " ++ revn ++ ") " chglog = revto ++ case mblogmg of Nothing -> defaultSummary cfg Just m -> m -- Try to create the file, if failed then try to modify its revision -- that was retrieved for editing that is, `mblatrev'. Always try to form -- a result of `modify'. If file name is not present, return Right () -- just like a successful storage operation was completed. mrgr <- liftIO $ do case (mbfile, mbtext) of (Nothing, _) -> return $ Right () (_, Nothing) -> return $ Right () (Just file, Just text) -> if (not update) then return (Right ()) else (create fs file (Author author "") chglog text >> return (Right ())) `catch` (\e -> if e == ResourceExists then (modify fs file (fromJust mblatrev) (Author author "") chglog text) `catch` (\u -> if u == Unchanged then return $ Right () else throwIO u) else throwIO e) -- Get the file status using the name and revision requested provided. fstat <- liftIO $ do if isNothing mbfile then return FSNeedName else do let file = fromJust mbfile lrev <- catch (latest fs file) (\e -> if e == NotFound then return "!" else return ('@':show e)) catch (do text <- retrieve fs file mbrevn case lrev of "!" -> return FSNameNotExist '@':e -> return $ FSError e _ -> do revid <- revision fs lrev >>= return . revId return $ FSExist file (fromMaybe revid mbrevn) revid text) (\e -> if e == NotFound && isJust mbrevn then return FSRevNotExist else if e == NotFound then return FSNameNotExist else return $ FSError $ show e) -- Depending on the file status either open an editor or fail with message. when (fstat == FSRevNotExist) $ fail $ "Revision " ++ fromJust mbrevn ++ " of file " ++ fromJust mbfile ++ " does not exist" when (fstat == FSNeedName && isJust mbrevn) $ fail $ "Revision specified without file name" when (fstat == FSNameNotExist && isNothing mbu) $ fail $ "Anonymous users cannot create files even in the anonymous editing area" when (isFSError fstat) $ let FSError e = fstat in fail $ "File store error " ++ e let mrgmsg (Right _) = "" mrgmsg (Left (MergeInfo revn conf txt)) = "File has been edited since you checked it out. " ++ "Changes from revision " ++ revId revn ++ " have been nerged into your edits below. " ++ if conf then "Please resolve conflicts and Save." else "Please review and Save." msg = if null chglog then "Description of changes cannot be empty" else if mrgr == Right () && isNothing mbtext && isJust mblatrev then "Empty file cannot be saved; delete the file instead" else mrgmsg mrgr -- If a name is needed, show an entry field for it, otherwise open the editor frame -- and create the submit form. let mkhtml = RawHtml . showHtmlFragment cmcfg = defaultConfig json = "var CodeMirrorConfig = " ++ encode (toJSON_generic cmcfg) ++ ";" scr = script ! [thetype "text/javascript"] << primHtml json case fstat of FSNeedName -> do let getfn = p << [label << "Enter file name to edit:" ,spaceHtml ,textfield "file" ,br ,submit "" "Edit"] return $ BlockQuote $ map mkhtml [ form ! [method "GET", identifier "getfilename"] << [getfn] ,scr] _ -> do let raw = case (mbtext, mrgr, fstat) of (_, Left (MergeInfo revn conf mrgtxt), _) -> mrgtxt (Nothing, Right (), FSNameNotExist) -> "" (Just txt, Right (), FSExist _ _ _ t) -> if cancel then t else txt (Nothing, Right (), FSExist _ _ _ t) -> t _ -> fail $ show fstat ++ " was not expected here" mime <- liftIO $ do case fstat of FSNameNotExist -> return "text/plain" FSNeedName -> return "text/plain" FSExist edfile _ _ _ -> do let repo = repositoryPath cfg (ec, out, err) <- readProcessWithExitCode "file" ["-i", "-b", repo `combine` edfile] "" case ec of ExitSuccess -> return out _ -> return $ "error/error; " ++ err when (not ("text/" `isPrefixOf` mime)) $ fail $ "File " ++ fromJust mbfile ++ " has MIME type " ++ mime ++ " which cannot be edited by this editor" let xmsg = if null msg then noHtml else p ! [theclass "messages"] << [label << msg] xh = textarea ! [cols "80" ,thestyle "display:none" ,name "editedText" ,identifier "editedText"] << raw cbnew = (case fstat of FSExist _ _ _ _ -> label << "File: " _ -> label << "New file: ") +++ fromJust mbfile (lastlab, lastrev) = case fstat of FSExist _ grev lrev _ -> (label << "Latest Revision: " +++ lrev, textfield "latest" ! [thestyle "display:none", value lrev]) _ -> (noHtml, noHtml) (revlab, revid) = case mbrevn of Nothing -> (noHtml, noHtml) Just sha1 -> (label << "Revert to: " +++ sha1, textfield "revertTo" ! [thestyle "display:none", value sha1]) keepfn = textfield "file" ! [thestyle "display:none", value $ fromJust mbfile] logmsg = p << [label << "Description of changes:" ,textfield "logMsg" ! [value $ fromMaybe "" mblogmg]] return $ BlockQuote $ map mkhtml [ xmsg ,form ! [action $ rqUri req, method "POST", identifier "editform"] << [ label << mime ,p << ([cbnew, keepfn, spaceHtml, lastlab, lastrev, spaceHtml, revlab, revid]) ,xh ,logmsg ,submit "cm_update" "Save" ,primHtmlChar "nbsp" ,submit "cm_update" "Discard"] ,scr])(\e -> return $ Plain [Strong [Str $ ioeGetErrorString e]]) transformBlock x = return x -- Data structure reflecting the status of the file in the storage. data FStatus = FSExist FilePath RevisionId RevisionId String -- file exists, with given/latest revision -- and contents | FSNameNotExist -- file does not exist (by name) | FSRevNotExist -- requested revision does not exist | FSNeedName -- need to ask name of the file when editing | FSError String -- error occurred while retrieving deriving (Eq, Show) isFSError (FSError _) = True isFSError _ = False isFSExist (FSExist _ _ _ _) = True isFSExist _ = False -- Data structure to be filled from the request and -- embedded on the page with CodeMirror. data CMConfig = CMConfig { lineNumbers :: Bool ,textWrapping :: Bool ,stylesheet :: String ,parserfile :: String ,path :: String ,height :: String } deriving (Data, Typeable) defaultConfig :: CMConfig defaultConfig = CMConfig { lineNumbers = True ,textWrapping = False ,stylesheet = "/codemirror/css/plain.css" -- no highlighting at all ,parserfile = "parsedummy.js" -- corresponding parser for plain text ,path = "/codemirror/js/" -- coordinate with actual location ,height = "21em"} -- approx. 20 lines per current CSS settings