gitit 0.3.3 → 0.3.4
raw patch · 7 files changed
+196/−69 lines, 7 files
Files
- Gitit.hs +59/−54
- Gitit/Git.hs +43/−13
- Gitit/HAppS.hs +52/−0
- Gitit/HStringTemplate.hs +31/−0
- README.markdown +7/−0
- data/template.html +1/−0
- gitit.cabal +3/−2
Gitit.hs view
@@ -19,7 +19,8 @@ module Main where -import HAppS.Server+import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie)+import Gitit.HAppS (look, lookRead, lookCookieValue, mkCookie) import HAppS.State hiding (Method) import System.Environment import System.IO.UTF8@@ -40,6 +41,7 @@ import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) import Data.ByteString.UTF8 (fromString, toString) import qualified Data.ByteString.Lazy.UTF8 as L (fromString)+import Codec.Binary.UTF8.String (decodeString, encodeString) import qualified Data.Map as M import Data.Ord (comparing) import Data.Digest.Pure.SHA (sha512, showDigest)@@ -51,11 +53,12 @@ import Data.Char (isAlphaNum, isAlpha) import Control.Monad.Reader import qualified Data.ByteString.Lazy as B-import Network.HTTP (urlEncodeVars, urlEncode, urlDecode)+import Network.HTTP (urlEncodeVars, urlEncode) import System.Console.GetOpt 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) @@ -88,12 +91,12 @@ else return M.empty update $ SetUsers users' hPutStrLn stderr $ "Starting server on port " ++ show (portNumber conf)- let debugger = if (debugMode conf) then debugFilter else id+ let debugger = if debugMode conf then debugFilter else id tid <- forkIO $ simpleHTTP (Conf { validator = Nothing, port = portNumber conf }) $ debugger $- [ dir "css" [ fileServe [] $ (staticDir conf) </> "css" ]- , dir "img" [ fileServe [] $ (staticDir conf) </> "img" ]- , dir "js" [ fileServe [] $ (staticDir conf) </> "js" ]- ] ++ wikiHandlers+ [ dir "css" [ fileServe [] $ staticDir conf </> "css" ]+ , dir "img" [ fileServe [] $ staticDir conf </> "img" ]+ , dir "js" [ fileServe [] $ staticDir conf </> "js" ]+ ] ++ (if debugMode conf then debugHandlers else []) ++ wikiHandlers waitForTermination putStrLn "Shutting down..." -- write user file@@ -142,7 +145,7 @@ case opt of Help -> hPutStrLn stderr (usageInfo (usageHeader progname) flags) >> exitWith ExitSuccess Version -> hPutStrLn stderr (progname ++ " version " ++ gititVersion ++ copyrightMessage) >> exitWith ExitSuccess- ConfigFile f -> do readFile f >>= return . read+ ConfigFile f -> liftM read (readFile f) entryPoint :: Proxy AppState entryPoint = Proxy@@ -188,20 +191,20 @@ createDirectoryIfMissing True $ staticdir </> "css" let stylesheets = map ("css" </>) ["screen.css", "print.css", "ie.css", "hk-pyg.css"] stylesheetpaths <- mapM getDataFileName stylesheets- zipWithM copyFile stylesheetpaths (map (staticdir </>) stylesheets)+ zipWithM_ copyFile stylesheetpaths (map (staticdir </>) stylesheets) createDirectoryIfMissing True $ staticdir </> "img" </> "icons"- let imgs = map ("img" </>) $ map ("icons" </>)- ["cross.png", "doc.png", "email.png", "external.png", "feed.png", "folder.png",- "im.png", "key.png", "page.png", "pdf.png", "tick.png", "xls.png"]+ let imgs = map (("img" </>) . ("icons" </>))+ ["cross.png", "doc.png", "email.png", "external.png", "feed.png", "folder.png",+ "im.png", "key.png", "page.png", "pdf.png", "tick.png", "xls.png"] imgpaths <- mapM getDataFileName imgs- zipWithM copyFile imgpaths (map (staticdir </>) imgs)+ zipWithM_ copyFile imgpaths (map (staticdir </>) imgs) logopath <- getDataFileName $ "img" </> "gitit-dog.png" copyFile logopath (staticdir </> "img" </> "logo.png") createDirectoryIfMissing True $ staticdir </> "js" let javascripts = ["jquery.min.js", "jquery-ui.packed.js", "folding.js", "dragdiff.js", "preview.js", "search.js", "uploadForm.js"] javascriptpaths <- mapM getDataFileName $ map ("js" </>) javascripts- zipWithM copyFile javascriptpaths $ map ((staticdir </> "js") </>) javascripts+ zipWithM_ copyFile javascriptpaths $ map ((staticdir </> "js") </>) javascripts hPutStrLn stderr $ "Created " ++ staticdir ++ " directory" jsMathExists <- doesDirectoryExist (staticdir </> "js" </> "jsMath") unless jsMathExists $ do@@ -219,6 +222,10 @@ type Handler = ServerPart Response +debugHandlers :: [Handler]+debugHandlers = [ withCommand "debug" [ handlePage GET $ \page params -> ok (toResponse $ show (page, params)),+ handlePage POST $ \page params -> ok (toResponse $ show (page, params)) ] ]+ wikiHandlers :: [Handler] wikiHandlers = [ handlePath "_index" GET indexPage , handlePath "_activity" GET showActivity@@ -354,12 +361,12 @@ data Command = Command (Maybe String) commandList :: [String]-commandList = ["edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"]+commandList = ["debug", "edit", "showraw", "history", "export", "diff", "cancel", "update", "delete", "discuss"] instance FromData Command where fromData = do pairs <- lookPairs- return $ case (map fst pairs) `intersect` commandList of+ return $ case map fst pairs `intersect` commandList of [] -> Command Nothing (c:_) -> Command $ Just c @@ -393,19 +400,18 @@ responder page (params { pUser = u, pEmail = e }) handle :: (String -> Bool) -> Method -> (String -> Params -> Web Response) -> Handler-handle pathtest meth responder =- withRequest $ \req -> let uri = urlDecode $ rqUri req ++ rqQuery req- path' = uriPath uri- referer = case M.lookup (fromString "referer") (rqHeaders req) of- Just r -> if null (hValue r)- then Nothing- else Just $ toString $ head $ hValue r- _ -> Nothing- in if pathtest path' && rqMethod req == meth- then unServerPartT- (withData $ \params ->- [ anyRequest $ responder path' (params { pReferer = referer, pUri = uri }) ]) req- else noHandle+handle pathtest meth responder = uriRest $ \uri ->+ let path' = decodeString $ uriPath uri+ in if pathtest path'+ then withData $ \params ->+ [ withRequest $ \req ->+ if rqMethod req == meth+ then let referer = case M.lookup (fromString "referer") (rqHeaders req) of+ Just r | not (null (hValue r)) -> Just $ toString $ head $ hValue r+ _ -> Nothing+ in responder path' (params { pReferer = referer, pUri = uri })+ else noHandle ]+ else anyRequest noHandle -- | Returns path portion of URI, without initial /. -- Consecutive spaces are collapsed. We don't want to distinguish 'Hi There' and 'Hi There'.@@ -457,7 +463,7 @@ isSourceCode = not . null . languagesByExtension . takeExtension urlForPage :: String -> String-urlForPage page = "/" ++ (substitute "%2f" "/" $ urlEncode page)+urlForPage page = '/' : (substitute "%2f" "/" $ urlEncode $ encodeString page) -- this is needed so that browsers recognize relative URLs correctly pathForPage :: String -> FilePath@@ -486,7 +492,7 @@ in res { rsHeaders = M.insert (fromString "content-disposition") newContentType respHeaders } showRawPage :: String -> Params -> Web Response-showRawPage page = showFileAsText $ pathForPage page+showRawPage = showFileAsText . pathForPage showFileAsText :: String -> Params -> Web Response showFileAsText file params = do@@ -497,7 +503,7 @@ randomPage :: String -> Params -> Web Response randomPage _ _ = do- files <- gitLsTree "HEAD" >>= return . map (unwords . drop 3 . words) . lines+ files <- gitLsTree "HEAD" let pages = map dropExtension $ filter (\f -> takeExtension f == ".page" && not (":discuss.page" `isSuffixOf` f)) files if null pages then error "No pages found!"@@ -521,7 +527,7 @@ "?edit&revision=" ++ revision ++ (if revision == "HEAD" then ""- else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)]) ++ "';")] << cont+ else '&' : urlEncodeVars [("logMsg", "Revert to " ++ revision)]) ++ "';")] << cont formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js"]}) page params cont' _ -> if revision == "HEAD" then createPage page params@@ -586,12 +592,11 @@ ] if null errors then do- if B.length fileContents > fromIntegral (maxUploadSize cfg)- then error "File exceeds maximum upload size"- else return ()+ when (B.length fileContents > fromIntegral (maxUploadSize cfg)) $+ error "File exceeds maximum upload size" let dir' = takeDirectory wikiname liftIO $ createDirectoryIfMissing True ((repositoryPath cfg) </> dir')- liftIO $ B.writeFile ((repositoryPath cfg) </> wikiname) fileContents+ liftIO $ B.writeFile (repositoryPath cfg </> wikiname) fileContents gitCommit wikiname (author, email) logMsg formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Upload successful" }) page params $ thediv << [ h2 << ("Uploaded " ++ show (B.length fileContents) ++ " bytes")@@ -609,7 +614,7 @@ let limit = pLimit params matchLines <- if null patterns then return []- else gitGrep patterns >>= return . map parseMatchLine . take limit . lines+ else liftM (map parseMatchLine . take limit . lines) (gitGrep patterns) let matchedFiles = nub $ filter (".page" `isSuffixOf`) $ map fst matchLines let matches = map (\f -> (f, mapMaybe (\(a,b) -> if a == f then Just b else Nothing) matchLines)) matchedFiles let preamble = if null matches@@ -808,7 +813,7 @@ indexPage _ params = do let page = "_index" let revision = pRevision params- files <- gitLsTree revision >>= return . map (unwords . drop 3 . words) . lines+ files <- gitLsTree 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 @@ -919,23 +924,23 @@ else ulist ! [theclass "messages"] << map (li <<) messages templ <- liftIO $ readIORef template let filledTemp = T.render $- T.setAttribute "pagetitle" pageTitle $- T.setAttribute "javascripts" javascriptlinks $- T.setAttribute "pagename" page $+ setAttribute "pagetitle" pageTitle $+ setAttribute "javascripts" javascriptlinks $+ setAttribute "pagename" page $ (case user of- Just u -> T.setAttribute "user" u+ Just u -> setAttribute "user" u Nothing -> id) $- (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) $+ (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) $ templ ok $ setContentType "text/html" $ toResponse filledTemp
Gitit/Git.hs view
@@ -16,8 +16,11 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{- Auxiliary functions for running git commands -}+{- Auxiliary functions for running git commands. + Note: UTF-8 locale is assumed.+-}+ module Gitit.Git ( runGitCommand , gitLastCommitHash@@ -33,19 +36,20 @@ , LogEntry (..) ) where -import Control.Monad (unless)+import Control.Monad (unless, liftM) import Control.Monad.Trans import Network.CGI (urlEncode)-import System.FilePath import System.Exit import System.Process import qualified Text.ParserCombinators.Parsec as P-import qualified Data.ByteString.Lazy as B import System.Directory import System.IO (openTempFile)-import Data.ByteString.Lazy.UTF8 (toString)+import Prelude hiding (readFile, writeFile)+import System.IO.UTF8+import Codec.Binary.UTF8.String (encodeString, decodeString) import HAppS.State 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)@@ -55,16 +59,18 @@ (errorPath, hErr) <- openTempFile tempPath "err" hProcess <- runProcess command optionList (Just workingDir) environment Nothing (Just hOut) (Just hErr) status <- waitForProcess hProcess- errorOutput <- B.readFile errorPath >>= return . toString- output <- B.readFile outputPath >>= return . toString+ 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 <- (query GetConfig) >>= return . repositoryPath- liftIO $ runShellCommand repo Nothing "git" (command : args)+ repo <- liftM repositoryPath (query GetConfig)+ liftIO $ runShellCommand repo Nothing "git" (command : map encodeString args) -- | Return SHA1 hash of last commit for filename. gitLastCommitHash :: MonadIO m => String -> m (Maybe String)@@ -89,13 +95,37 @@ Right parsed -> return parsed else error $ "git whatchanged returned error status.\n" ++ err -gitLsTree :: MonadIO m => String -> m String+gitLsTree :: MonadIO m => String -> m [String] gitLsTree rev = do (status, errOutput, output) <- runGitCommand "ls-tree" ["-r", rev] if status == ExitSuccess- then return output+ then return $ map (convertEncoded . (unwords . drop 3 . words)) $ lines output else error $ "git ls-tree returned error status.\n" ++ errOutput +-- | git ls-tree returns UTF-8 filenames in quotes, with characters octal-escaped.+-- like this: "\340\244\226.page"+-- This function decodes these.+convertEncoded :: String -> String+convertEncoded s =+ case P.parse pEncodedString s s of+ Left _ -> s+ Right res -> res++pEncodedString :: P.GenParser Char st [Char]+pEncodedString = do+ P.char '"'+ res <- P.many1 (pOctalChar P.<|> P.anyChar)+ if last res == '"'+ then return $ decodeString $ init res+ else fail "No ending quotation mark."++pOctalChar :: P.GenParser Char st Char+pOctalChar = P.try $ do+ P.char '\\'+ ds <- P.count 3 (P.oneOf "01234567")+ let num = read $ "0o" ++ ds+ return $ chr num+ gitGrep :: MonadIO m => [String] -> m String gitGrep patterns = do (status, errOutput, output) <- runGitCommand "grep" (["--all-match", "--ignore-case", "--word-regexp"] ++@@ -117,7 +147,7 @@ -> String -- ^ New version (sha1) -> m String -- ^ String gitDiff file from to = do- repo <- (query GetConfig) >>= return . repositoryPath+ repo <- liftM repositoryPath (query GetConfig) (status, _, output) <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) "git" ["diff", from, to, file] if status == ExitSuccess@@ -196,7 +226,7 @@ rev <- nonblankLine date <- nonblankLine author <- wholeLine- subject <- P.manyTill wholeLine (P.eof P.<|> (P.lookAhead (P.char ':') >> return ())) >>= return . unlines+ subject <- liftM unlines (P.manyTill wholeLine (P.eof P.<|> (P.lookAhead (P.char ':') >> return ()))) P.spaces files <- P.many gitLogChange P.spaces
+ Gitit/HAppS.hs view
@@ -0,0 +1,52 @@+{-+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 HAppS functions that don't handle UTF-8 properly.+-}++module Gitit.HAppS+ ( look+ , lookRead+ , lookCookieValue+ , mkCookie+ )+where+import HAppS.Server hiding (look, lookRead, lookCookieValue, mkCookie)+import qualified HAppS.Server (lookCookieValue, mkCookie)+import Text.Pandoc.CharacterReferences (decodeCharacterReferences)+import Control.Monad (liftM)+import Data.ByteString.Lazy.UTF8 (toString)+import Codec.Binary.UTF8.String (encodeString, decodeString)++-- HAppS's look, lookRead, and lookCookieValue encode unicode characters+-- (outside the standard latin1 range) using decimal character+-- references. For gitit's purposes, we want them to return regular+-- unicode characters instead.++look :: String -> RqData String+look = liftM (decodeCharacterReferences . toString) . HAppS.Server.lookBS++lookRead :: Read a => String -> RqData a+lookRead = liftM read . look++lookCookieValue :: String -> RqData String+lookCookieValue = liftM decodeString . HAppS.Server.lookCookieValue++mkCookie :: String -> String -> Cookie+mkCookie name val = HAppS.Server.mkCookie name (encodeString val)+
+ Gitit/HStringTemplate.hs view
@@ -0,0 +1,31 @@+{-+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
README.markdown view
@@ -246,6 +246,13 @@ version of gitit, with a different `AppState` data structure, because the new gitit will not be able to read the old gitit's state. +Character encodings+===================++Gitit assumes that the page files (stored in the git repository) are+encoded as UTF-8. Even page names may be UTF-8 if the file system supports+this. You should use a UTF-8 locale when running gitit.+ Reporting bugs ==============
data/template.html view
@@ -2,6 +2,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head>+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /> <title>Wiki - $pagetitle$</title> $if(printable)$ <link href="/css/print.css" rel="stylesheet" media="all" type= "text/css" />
gitit.cabal view
@@ -1,5 +1,5 @@ name: gitit-version: 0.3.3+version: 0.3.4 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc.@@ -42,7 +42,8 @@ Executable gitit hs-source-dirs: . main-is: Gitit.hs - other-modules: Gitit.State, Gitit.Git, Paths_gitit+ other-modules: Gitit.State, Gitit.Git, Gitit.HAppS, Gitit.HStringTemplate,+ Paths_gitit build-depends: base >=3, parsec < 3, pretty, xhtml, containers, pandoc >= 1.1, process, filepath, directory, mtl, cgi, network, old-time, highlighting-kate, bytestring,