gitit 0.4.1 → 0.4.1.2
raw patch · 7 files changed
+118/−109 lines, 7 files
Files
- Gitit.hs +46/−36
- Gitit/Git.hs +10/−29
- Gitit/HAppS.hs +1/−2
- Gitit/HStringTemplate.hs +0/−31
- Gitit/Shell.hs +51/−0
- Gitit/State.hs +8/−9
- gitit.cabal +2/−2
Gitit.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {- Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu> @@ -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 "<!-- raw HTML removed -->"+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)
Gitit/Git.hs view
@@ -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
Gitit/HAppS.hs view
@@ -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
− Gitit/HStringTemplate.hs
@@ -1,31 +0,0 @@-{--Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>--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
+ Gitit/Shell.hs view
@@ -0,0 +1,51 @@+{-+Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>++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)
Gitit/State.hs view
@@ -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
gitit.cabal view
@@ -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,