diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {- Copyright (C) 2008 John MacFarlane @@ -56,14 +55,13 @@ import System.Exit import Text.Highlighting.Kate import qualified Text.StringTemplate as T -import Gitit.HStringTemplate (setAttribute) import Data.IORef import System.IO.Unsafe (unsafePerformIO) import Network.Socket import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) gititVersion :: String -gititVersion = "0.4.1" +gititVersion = "0.4.1.2" sessionTime :: Int sessionTime = 60 * 60 -- session will expire 1 hour after page request @@ -522,16 +520,19 @@ showRawPage :: String -> Params -> Web Response showRawPage = showFileAsText . pathForPage +responseAndEncodeWithType :: String -> String -> Web Response +responseAndEncodeWithType typ = ok . setContentType typ . toResponse . encodeString + showFileAsText :: String -> Params -> Web Response showFileAsText file params = do mContents <- rawContents file params case mContents of Nothing -> error "Unable to retrieve page contents." - Just c -> ok $ setContentType "text/plain; charset=utf-8" $ toResponse $ encodeString c + Just c -> responseAndEncodeWithType "text/plain; charset=utf-8" c randomPage :: String -> Params -> Web Response randomPage _ _ = do - files <- gitLsTree "HEAD" + files <- gitListFiles "HEAD" let pages = map dropExtension $ filter (\f -> takeExtension f == ".page" && not (":discuss.page" `isSuffixOf` f)) files if null pages then error "No pages found!" @@ -666,8 +667,8 @@ in (file, contents) preview :: String -> Params -> Web Response -preview _ params = pandocToHtml (textToPandoc $ pRaw params) >>= ok . toResponse - +preview _ params = pandocToHtml (textToPandoc $ pRaw params) >>= (responseAndEncodeWithType "text/plain; charset=utf-8") . show + showPageHistory :: String -> Params -> Web Response showPageHistory page params = showHistory (pathForPage page) page params @@ -841,7 +842,7 @@ indexPage _ params = do let page = "_index" let revision = pRevision params - files <- gitLsTree revision + files <- gitListFiles revision let htmlIndex = fileListToHtml "/" $ map splitPath $ sort $ filter (\f -> not (":discuss.page" `isSuffixOf` f)) files formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgScripts = ["folding.js"], pgTitle = "All pages" }) page params htmlIndex @@ -952,25 +953,25 @@ else ulist ! [theclass "messages"] << map (li <<) messages templ <- liftIO $ readIORef template let filledTemp = T.render $ - setAttribute "pagetitle" pageTitle $ - setAttribute "javascripts" javascriptlinks $ - setAttribute "pagename" page $ + T.setAttribute "pagetitle" pageTitle $ + T.setAttribute "javascripts" javascriptlinks $ + T.setAttribute "pagename" page $ (case user of - Just u -> setAttribute "user" u + Just u -> T.setAttribute "user" u Nothing -> id) $ - (if isPage page then setAttribute "ispage" "true" else id) $ - (if pgShowPageTools layout then setAttribute "pagetools" "true" else id) $ - (if pPrintable params then setAttribute "printable" "true" else id) $ - (if pRevision params == "HEAD" then id else setAttribute "nothead" "true") $ - setAttribute "revision" revision $ - setAttribute "sha1" sha1 $ - setAttribute "searchbox" (renderHtmlFragment searchbox) $ - setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ - setAttribute "tabs" (renderHtmlFragment tabs) $ - setAttribute "messages" (renderHtmlFragment htmlMessages) $ - setAttribute "content" (renderHtmlFragment htmlContents) $ + (if isPage page then T.setAttribute "ispage" "true" else id) $ + (if pgShowPageTools layout then T.setAttribute "pagetools" "true" else id) $ + (if pPrintable params then T.setAttribute "printable" "true" else id) $ + (if pRevision params == "HEAD" then id else T.setAttribute "nothead" "true") $ + T.setAttribute "revision" revision $ + T.setAttribute "sha1" sha1 $ + T.setAttribute "searchbox" (renderHtmlFragment searchbox) $ + T.setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ + T.setAttribute "tabs" (renderHtmlFragment tabs) $ + T.setAttribute "messages" (renderHtmlFragment htmlMessages) $ + T.setAttribute "content" (renderHtmlFragment htmlContents) $ templ - ok $ setContentType "text/html" $ toResponse filledTemp + responseAndEncodeWithType "text/html" filledTemp -- user authentication loginForm :: Html @@ -1102,40 +1103,44 @@ defaultRespOptions :: WriterOptions defaultRespOptions = defaultWriterOptions { writerStandalone = True, writerWrapText = True } +responseAndEncodeWithTypeAndName :: String -> String -> String -> Web Response +responseAndEncodeWithTypeAndName typ name' = ok . setContentType typ . setFilename name' . toResponse . encodeString + + respondLaTeX :: String -> Pandoc -> Web Response -respondLaTeX page = ok . setContentType "application/x-latex" . setFilename (page ++ ".tex") . toResponse . +respondLaTeX page = responseAndEncodeWithTypeAndName "application/x-latex" (page ++ ".tex") . writeLaTeX (defaultRespOptions {writerHeader = defaultLaTeXHeader}) respondConTeXt :: String -> Pandoc -> Web Response -respondConTeXt page = ok . setContentType "application/x-context" . setFilename (page ++ ".tex") . toResponse . - writeConTeXt (defaultRespOptions {writerHeader = defaultConTeXtHeader}) +respondConTeXt page = responseAndEncodeWithTypeAndName "application/x-context" (page ++ ".tex") . + writeConTeXt (defaultRespOptions {writerHeader = defaultConTeXtHeader}) respondRTF :: String -> Pandoc -> Web Response -respondRTF page = ok . setContentType "application/rtf" . setFilename (page ++ ".rtf") . toResponse . +respondRTF page = responseAndEncodeWithTypeAndName "application/rtf" (page ++ ".rtf") . writeRTF (defaultRespOptions {writerHeader = defaultRTFHeader}) respondRST :: String -> Pandoc -> Web Response -respondRST _ = ok . setContentType "text/plain" . toResponse . +respondRST _ = responseAndEncodeWithType "text/plain; charset=utf-8" . writeRST (defaultRespOptions {writerHeader = "", writerReferenceLinks = True}) respondMan :: String -> Pandoc -> Web Response -respondMan _ = ok . setContentType "text/plain" . toResponse . +respondMan _ = responseAndEncodeWithType "text/plain; charset=utf-8" . writeMan (defaultRespOptions {writerHeader = ""}) respondS5 :: String -> Pandoc -> Web Response -respondS5 _ = ok . toResponse . writeS5 (defaultRespOptions {writerHeader = defaultS5Header, - writerS5 = True, writerIncremental = True}) +respondS5 _ = ok . toResponse . writeS5 (defaultRespOptions {writerHeader = defaultS5Header, + writerS5 = True, writerIncremental = True}) respondTexinfo :: String -> Pandoc -> Web Response -respondTexinfo page = ok . setContentType "application/x-texinfo" . setFilename (page ++ ".texi") . toResponse . +respondTexinfo page = responseAndEncodeWithTypeAndName "application/x-texinfo" (page ++ ".texi") . writeTexinfo (defaultRespOptions {writerHeader = ""}) respondDocbook :: String -> Pandoc -> Web Response -respondDocbook page = ok . setContentType "application/docbook+xml" . setFilename (page ++ ".xml") . toResponse . +respondDocbook page = responseAndEncodeWithTypeAndName "application/docbook+xml" (page ++ ".xml") . writeDocbook (defaultRespOptions {writerHeader = defaultDocbookHeader}) respondMediaWiki :: String -> Pandoc -> Web Response -respondMediaWiki _ = ok . setContentType "text/plain" . toResponse . +respondMediaWiki _ = responseAndEncodeWithType "text/plain; charset=utf-8" . writeMediaWiki (defaultRespOptions {writerHeader = ""}) respondODT :: String -> Pandoc -> Web Response @@ -1174,8 +1179,13 @@ let revision = pRevision params `orIfNull` "HEAD" gitCatFile revision file +removeRawHtmlBlock :: Block -> Block +removeRawHtmlBlock (RawHtml _) = RawHtml "" +removeRawHtmlBlock x = x + textToPandoc :: String -> Pandoc -textToPandoc = readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) . +textToPandoc = processPandoc removeRawHtmlBlock . + readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) . filter (/= '\r') pageAsPandoc :: String -> Params -> Web (Maybe Pandoc) diff --git a/Gitit/Git.hs b/Gitit/Git.hs --- a/Gitit/Git.hs +++ b/Gitit/Git.hs @@ -25,7 +25,7 @@ ( runGitCommand , gitLastCommitHash , gitLog - , gitLsTree + , gitListFiles , gitGrep , gitCatFile , gitDiff @@ -40,37 +40,21 @@ import Control.Monad.Trans import Network.CGI (urlEncode) import System.Exit -import System.Process import qualified Text.ParserCombinators.Parsec as P -import System.Directory -import System.IO (openTempFile) import Prelude hiding (readFile, writeFile) -import System.IO.UTF8 -import Codec.Binary.UTF8.String (encodeString, decodeString) +import Codec.Binary.UTF8.String (decodeString) import HAppS.State +import Gitit.Shell (runProgCommand) import Gitit.State import Data.Char (chr) --- | Run shell command and return error status, standard output, and error output. -runShellCommand :: FilePath -> Maybe [(String, String)] -> String -> [String] -> IO (ExitCode, String, String) -runShellCommand workingDir environment command optionList = do - tempPath <- getTemporaryDirectory - (outputPath, hOut) <- openTempFile tempPath "out" - (errorPath, hErr) <- openTempFile tempPath "err" - hProcess <- runProcess command optionList (Just workingDir) environment Nothing (Just hOut) (Just hErr) - status <- waitForProcess hProcess - errorOutput <- readFile errorPath - output <- readFile outputPath - removeFile errorPath - removeFile outputPath - return (status, errorOutput, output) - -- | Run git command and return error status, standard output, and error output. The repository -- is used as working directory. runGitCommand :: MonadIO m => String -> [String] -> m (ExitCode, String, String) runGitCommand command args = do repo <- liftM repositoryPath (query GetConfig) - liftIO $ runShellCommand repo Nothing "git" (command : map encodeString args) + let env = Just [("GIT_DIFF_OPTS","-u100000")] + liftIO $ runProgCommand repo env "git" command args -- | Return SHA1 hash of last commit for filename. gitLastCommitHash :: MonadIO m => String -> m (Maybe String) @@ -95,8 +79,8 @@ Right parsed -> return parsed else error $ "git whatchanged returned error status.\n" ++ err -gitLsTree :: MonadIO m => String -> m [String] -gitLsTree rev = do +gitListFiles :: MonadIO m => String -> m [String] +gitListFiles rev = do (status, errOutput, output) <- runGitCommand "ls-tree" ["-r", rev] if status == ExitSuccess then return $ map (convertEncoded . (unwords . drop 3 . words)) $ lines output @@ -147,15 +131,12 @@ -> String -- ^ New version (sha1) -> m String -- ^ String gitDiff file from to = do - repo <- liftM repositoryPath (query GetConfig) - (status, _, output) <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) - "git" ["diff", from, to, file] + (status, _, output) <- runGitCommand "diff" [from, to, file] if status == ExitSuccess then return output else do -- try it without the path, since the error might be "not in working tree" for a deleted file - (status', errOut', output') <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) - "git" ["diff", from, to] + (status', errOut', output') <- runGitCommand "diff" [from, to] if status' == ExitSuccess then return output' else error $ "git diff returned error: " ++ errOut' @@ -234,7 +215,7 @@ logDate = date, logAuthor = author, logSubject = subject, - logFiles = files } + logFiles = map convertEncoded files } gitLogChange :: P.Parser String gitLogChange = do diff --git a/Gitit/HAppS.hs b/Gitit/HAppS.hs --- a/Gitit/HAppS.hs +++ b/Gitit/HAppS.hs @@ -48,5 +48,4 @@ lookCookieValue = liftM decodeString . HAppS.Server.lookCookieValue mkCookie :: String -> String -> Cookie -mkCookie name val = HAppS.Server.mkCookie name (encodeString val) - +mkCookie name = HAppS.Server.mkCookie name . encodeString diff --git a/Gitit/HStringTemplate.hs b/Gitit/HStringTemplate.hs deleted file mode 100644 --- a/Gitit/HStringTemplate.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- -Copyright (C) 2008 John MacFarlane - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- Replacements for HStringTemplate functions that don't handle - UTF-8 properly. --} - -module Gitit.HStringTemplate ( setAttribute ) -where -import Codec.Binary.UTF8.String (encodeString) -import qualified Text.StringTemplate as T - --- | A wrapper around HStringTemplate's setAttribute that encodes strings --- in UTF-8. -setAttribute :: String -> String -> T.StringTemplate String -> T.StringTemplate String -setAttribute attrName = T.setAttribute attrName . encodeString diff --git a/Gitit/Shell.hs b/Gitit/Shell.hs new file mode 100644 --- /dev/null +++ b/Gitit/Shell.hs @@ -0,0 +1,51 @@ +{- +Copyright (C) 2008 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- Auxiliary functions for running shell commands. + + Note: UTF-8 locale is assumed. +-} + +module Gitit.Shell where + +import Control.Monad.Trans (liftIO, MonadIO) +import System.Directory (getTemporaryDirectory, removeFile) +import System.Exit (ExitCode) +import System.IO (openTempFile) +import Prelude hiding (readFile) +import System.IO.UTF8 +import System.Process (runProcess, waitForProcess) +import Codec.Binary.UTF8.String (encodeString) + +-- | Run shell command and return error status, standard output, and error output. +runShellCommand :: FilePath -> Maybe [(String, String)] -> String -> [String] -> IO (ExitCode, String, String) +runShellCommand workingDir environment command optionList = do + tempPath <- getTemporaryDirectory + (outputPath, hOut) <- openTempFile tempPath "out" + (errorPath, hErr) <- openTempFile tempPath "err" + hProcess <- runProcess command optionList (Just workingDir) environment Nothing (Just hOut) (Just hErr) + status <- waitForProcess hProcess + errorOutput <- readFile errorPath + output <- readFile outputPath + removeFile errorPath + removeFile outputPath + return (status, errorOutput, output) + +runProgCommand :: MonadIO m => String -> Maybe [(String, String)] -> String -> String -> [String] -> m (ExitCode, String, String) +runProgCommand workingDir environment prog command args = do + liftIO $ runShellCommand workingDir environment prog (command : map encodeString args) diff --git a/Gitit/State.hs b/Gitit/State.hs --- a/Gitit/State.hs +++ b/Gitit/State.hs @@ -30,7 +30,7 @@ import qualified Data.Map as M import Control.Monad.Reader import Control.Monad.State (modify, MonadState) -import Data.Generics hiding ((:+:)) +import Data.Generics import HAppS.State import HAppS.Data import GHC.Conc (STM) @@ -152,17 +152,16 @@ uEmail = email } genSalt :: IO String -genSalt = - replicateM 32 $ randomRIO ('0','z') +genSalt = replicateM 32 $ randomRIO ('0','z') hashPassword :: String -> String -> String hashPassword salt pass = showDigest $ sha512 $ L.fromString $ salt ++ pass addUser :: MonadState AppState m => String -> User -> m () -addUser name u = modUsers $ M.insert name u +addUser name = modUsers . M.insert name delUser :: MonadState AppState m => String -> m () -delUser name = modUsers $ M.delete name +delUser = modUsers . M.delete authUser :: MonadReader AppState m => String -> String -> m Bool authUser name pass = do @@ -181,11 +180,11 @@ numUsers = liftM length listUsers isSession :: MonadReader AppState m => SessionKey -> m Bool -isSession key = liftM ((M.member key) . unsession) askSessions +isSession key = liftM (M.member key . unsession) askSessions setSession :: (MonadState AppState m) => SessionKey -> SessionData -> m () setSession key u = do - modSessions $ Sessions . (M.insert key u) . unsession + modSessions $ Sessions . M.insert key u . unsession return () newSession :: (MonadState AppState (Ev (t GHC.Conc.STM)), MonadTrans t, Monad (t GHC.Conc.STM)) => @@ -197,11 +196,11 @@ delSession :: (MonadState AppState m) => SessionKey -> m () delSession key = do - modSessions $ Sessions . (M.delete key) . unsession + modSessions $ Sessions . M.delete key . unsession return () getSession::SessionKey -> Query AppState (Maybe SessionData) -getSession key = liftM ((M.lookup key) . unsession) askSessions +getSession key = liftM (M.lookup key . unsession) askSessions getConfig :: Query AppState Config getConfig = return . config =<< ask diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,5 +1,5 @@ name: gitit -version: 0.4.1 +version: 0.4.1.2 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc. @@ -42,7 +42,7 @@ Executable gitit hs-source-dirs: . main-is: Gitit.hs - other-modules: Gitit.State, Gitit.Git, Gitit.HAppS, Gitit.HStringTemplate, + other-modules: Gitit.State, Gitit.Git, Gitit.HAppS, Gitit.Shell Paths_gitit build-depends: base >=3, parsec < 3, pretty, xhtml, containers, pandoc >= 1.1, process, filepath, directory, mtl, cgi,