diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -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 diff --git a/Gitit/Git.hs b/Gitit/Git.hs --- a/Gitit/Git.hs +++ b/Gitit/Git.hs @@ -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 diff --git a/Gitit/HAppS.hs b/Gitit/HAppS.hs new file mode 100644 --- /dev/null +++ b/Gitit/HAppS.hs @@ -0,0 +1,52 @@ +{- +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 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) + diff --git a/Gitit/HStringTemplate.hs b/Gitit/HStringTemplate.hs new file mode 100644 --- /dev/null +++ b/Gitit/HStringTemplate.hs @@ -0,0 +1,31 @@ +{- +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/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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 ============== diff --git a/data/template.html b/data/template.html --- a/data/template.html +++ b/data/template.html @@ -2,6 +2,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> + Wiki - $pagetitle$ $if(printable)$ diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -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,