diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Rank2Types, FlexibleContexts #-} {- Copyright (C) 2008 John MacFarlane @@ -20,24 +21,21 @@ 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 import System.IO (stderr) import System.IO.Error (isAlreadyExistsError) -import Control.Exception (bracket) -import Prelude hiding (writeFile, readFile, putStrLn, putStr) -import System.Process +import Control.Exception (bracket, throwIO, catch, try) +import Prelude hiding (writeFile, readFile, putStrLn, putStr, catch) import System.Directory import System.Time import Control.Concurrent import System.FilePath -import Gitit.Git import Gitit.State -import Text.XHtml hiding ( (), dir, method, password ) +import Text.XHtml hiding ( (), dir, method, password, rev ) import qualified Text.XHtml as X ( password, method ) -import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf) -import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) +import Data.List (intersect, intersperse, intercalate, sort, nub, sortBy, isSuffixOf, find, isPrefixOf) +import Data.Maybe (fromMaybe, fromJust, mapMaybe, isJust, isNothing) import Data.ByteString.UTF8 (fromString, toString) import Codec.Binary.UTF8.String (decodeString, encodeString) import qualified Data.Map as M @@ -47,64 +45,97 @@ import Text.Pandoc.ODT (saveOpenDocumentAsODT) import Text.Pandoc.Definition (processPandoc) import Text.Pandoc.Shared (HTMLMathMethod(..), substitute) -import Data.Char (isAlphaNum, isAlpha) +import Data.Char (isAlphaNum, isAlpha, toLower) import Control.Monad.Reader import qualified Data.ByteString.Lazy as B +import Codec.Compression.GZip (compress) import Network.HTTP (urlEncodeVars, urlEncode) import System.Console.GetOpt import System.Exit import Text.Highlighting.Kate import qualified Text.StringTemplate as T -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) +import Data.DateTime (getCurrentTime, addMinutes, parseDateTime, DateTime, formatDateTime) import Network.Socket import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha) +import Data.FileStore gititVersion :: String -gititVersion = "0.4.1.3" +gititVersion = "0.5" sessionTime :: Int sessionTime = 60 * 60 -- session will expire 1 hour after page request -template :: IORef (T.StringTemplate String) -template = unsafePerformIO $ newIORef $ T.newSTMP "" -- initialize template to empty string - main :: IO () main = do argv <- getArgs options <- parseArgs argv conf <- foldM handleFlag defaultConfig options - gitPath <- findExecutable "git" - when (isNothing gitPath) $ error "'git' program not found in system path." - initializeWiki conf - -- initialize template - templ <- liftIO $ readFile (templateFile conf) - writeIORef template (T.newSTMP templ) - control <- startSystemState entryPoint - update $ SetConfig conf + -- check for external programs that are needed + let prereqs = "grep" : case repository conf of + Git _ -> ["git"] + Darcs _ -> ["darcs"] + forM_ prereqs $ \prog -> + findExecutable prog >>= \mbFind -> + when (isNothing mbFind) $ error $ "Required program '" ++ prog ++ "' not found in system path." -- read user file and update state userFileExists <- doesFileExist $ userFile conf users' <- if userFileExists then readFile (userFile conf) >>= (return . M.fromList . read) else return M.empty - update $ SetUsers users' + -- create template file if it doesn't exist, and read it + let templatefile = templateFile conf + templateExists <- doesFileExist templatefile + unless templateExists $ do + templatePath <- getDataFileName $ "data" "template.html" + copyFile templatePath templatefile + hPutStrLn stderr $ "Created " ++ templatefile + templ <- liftIO $ readFile (templateFile conf) + -- initialize state + initializeAppState conf users' (T.newSTMP templ) + -- setup the page repository and static files, if they don't exist + initializeWiki conf + -- start the server hPutStrLn stderr $ "Starting server on port " ++ show (portNumber conf) 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" ] - ] ++ (if debugMode conf then debugHandlers else []) ++ wikiHandlers + tid <- forkIO $ simpleHTTP (Conf { validator = Nothing, port = portNumber conf }) $ + debugger $ + [ dir "css" [ withExpiresHeaders $ fileServe [] $ staticDir conf "css" ] + , dir "img" [ withExpiresHeaders $ fileServe [] $ staticDir conf "img" ] + , dir "js" [ withExpiresHeaders $ fileServe [] $ staticDir conf "js" ] + ] ++ + (if debugMode conf then debugHandlers else []) ++ + map (filterIf acceptsZip gzipBinary) wikiHandlers waitForTermination putStrLn "Shutting down..." - -- write user file - users'' <- query AskUsers - liftIO $ writeFile (userFile conf) (showPrettyList $ M.toList users'') killThread tid - createCheckpoint control - shutdownSystem control putStrLn "Shutdown complete" +filterIf :: (Request -> Bool) -> (Response -> Response) -> ServerPart Response -> ServerPart Response +filterIf test filt sp = + let handler = unServerPartT sp + in withRequest $ \req -> + if test req + then liftM filt $ handler req + else handler req + +gzipBinary :: Response -> Response +gzipBinary r@(Response {rsBody = b}) = setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b} + +acceptsZip :: Request -> Bool +acceptsZip req = isJust $ M.lookup (fromString "accept-encoding") (rqHeaders req) + +getCacheTime :: IO (Maybe DateTime) +getCacheTime = liftM (Just . addMinutes 360) $ getCurrentTime + +withExpiresHeaders :: ServerPart Response -> ServerPart Response +withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp] + +setContentType :: String -> Response -> Response +setContentType = setHeader "Content-Type" + +setFilename :: String -> Response -> Response +setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\"" + data Opt = Help | ConfigFile FilePath @@ -145,45 +176,22 @@ Version -> hPutStrLn stderr (progname ++ " version " ++ gititVersion ++ copyrightMessage) >> exitWith ExitSuccess ConfigFile f -> liftM read (readFile f) -entryPoint :: Proxy AppState -entryPoint = Proxy - -showPrettyList :: Show a => [a] -> String -showPrettyList lst = "[\n" ++ - concat (intersperse ",\n" $ map show lst) ++ "\n]" - - -- | Create repository and public directories, unless they already exist. initializeWiki :: Config -> IO () initializeWiki conf = do - let repodir = repositoryPath conf - let frontpage = frontPage conf <.> "page" let staticdir = staticDir conf - let templatefile = templateFile conf - repoExists <- doesDirectoryExist repodir + fs <- getFileStore + repoExists <- liftIO $ catch (initialize fs >> return False) + (\e -> if e == RepositoryExists then return True else throwIO e >> return False) unless repoExists $ do - postupdatepath <- getDataFileName $ "data" "post-update" - postupdatecontents <- B.readFile postupdatepath welcomepath <- getDataFileName $ "data" "FrontPage.page" welcomecontents <- B.readFile welcomepath helppath <- getDataFileName $ "data" "Help.page" helpcontents <- B.readFile helppath - createDirectory repodir - oldDir <- getCurrentDirectory - setCurrentDirectory repodir - runCommand "git init" >>= waitForProcess -- add front page and help page - B.writeFile frontpage welcomecontents - B.writeFile "Help.page" helpcontents - runCommand ("git add 'Help.page' '" ++ frontpage ++ "'; git commit -m 'Initial commit.'") >>= waitForProcess - -- set post-update hook so working directory will be updated - -- when changes are pushed to the repo - let postupdate = ".git" "hooks" "post-update" - B.writeFile postupdate postupdatecontents - perms <- getPermissions postupdate - setPermissions postupdate (perms {executable = True}) - hPutStrLn stderr $ "Created repository " ++ repodir - setCurrentDirectory oldDir + liftIO $ create fs (frontPage conf <.> "page") (Author "Gitit" "") "Default front page" welcomecontents + liftIO $ create fs "Help.page" (Author "Gitit" "") "Default front page" helpcontents + hPutStrLn stderr "Created repository" staticExists <- doesDirectoryExist staticdir unless staticExists $ do createDirectoryIfMissing True $ staticdir "css" @@ -205,17 +213,13 @@ zipWithM_ copyFile javascriptpaths $ map ((staticdir "js") ) javascripts hPutStrLn stderr $ "Created " ++ staticdir ++ " directory" jsMathExists <- doesDirectoryExist (staticdir "js" "jsMath") + updateAppState $ \s -> s{ jsMath = jsMathExists } unless jsMathExists $ do hPutStrLn stderr $ replicate 80 '*' ++ "\nWarning: jsMath not found.\n" ++ "If you want support for math, copy the jsMath directory into " ++ staticdir ++ "/js/\n" ++ "jsMath can be obtained from http://www.math.union.edu/~dpvc/jsMath/\n" ++ replicate 80 '*' - templateExists <- doesFileExist templatefile - unless templateExists $ do - templatePath <- getDataFileName $ "data" "template.html" - copyFile templatePath templatefile - hPutStrLn stderr $ "Created " ++ templatefile type Handler = ServerPart Response @@ -231,6 +235,7 @@ wikiHandlers = [ handlePath "_index" GET indexPage , handlePath "_activity" GET showActivity , handlePath "_preview" POST preview + , handlePath "_go" POST goToPage , handlePath "_search" POST searchResults , handlePath "_search" GET searchResults , handlePath "_register" GET registerUserForm @@ -241,6 +246,7 @@ , handlePath "_upload" GET (ifLoggedIn uploadForm) , handlePath "_upload" POST (ifLoggedIn uploadFile) , handlePath "_random" GET randomPage + , handlePath "" GET showFrontPage , withCommand "showraw" [ handlePage GET showRawPage ] , withCommand "history" [ handlePage GET showPageHistory, handle (not . isPage) GET showFileHistory ] @@ -266,19 +272,20 @@ data Params = Params { pUsername :: String , pPassword :: String , pPassword2 :: String - , pRevision :: String + , pRevision :: Maybe String , pDestination :: String , pReferer :: Maybe String , pUri :: String , pForUser :: String - , pSince :: String + , pSince :: Maybe DateTime , pRaw :: String , pLimit :: Int , pPatterns :: [String] + , pGotoPage :: String , pEditedText :: Maybe String , pMessages :: [String] - , pFrom :: String - , pTo :: String + , pFrom :: Maybe String + , pTo :: Maybe String , pFormat :: String , pSHA1 :: String , pLogMsg :: String @@ -302,16 +309,18 @@ un <- look "username" `mplus` return "" pw <- look "password" `mplus` return "" p2 <- look "password2" `mplus` return "" - rv <- look "revision" `mplus` return "HEAD" + rv <- (look "revision" >>= \s -> + return (if null s then Nothing else Just s)) `mplus` return Nothing fu <- look "forUser" `mplus` return "" - si <- look "since" `mplus` return "" + si <- (look "since" >>= return . parseDateTime "%Y-%m-%d") `mplus` return Nothing -- YYYY-mm-dd format ds <- (lookCookieValue "destination") `mplus` return "/" ra <- look "raw" `mplus` return "" lt <- look "limit" `mplus` return "100" pa <- look "patterns" `mplus` return "" + gt <- look "gotopage" `mplus` return "" me <- lookRead "messages" `mplus` return [] - fm <- look "from" `mplus` return "HEAD" - to <- look "to" `mplus` return "HEAD" + fm <- (look "from" >>= return . Just) `mplus` return Nothing + to <- (look "to" >>= return . Just) `mplus` return Nothing et <- (look "editedText" >>= return . Just . filter (/= '\r')) `mplus` return Nothing fo <- look "format" `mplus` return "" sh <- look "sha1" `mplus` return "" @@ -340,6 +349,7 @@ , pRaw = ra , pLimit = read lt , pPatterns = words pa + , pGotoPage = gt , pMessages = me , pFrom = fm , pTo = to @@ -364,7 +374,7 @@ getLoggedInUser :: MonadIO m => Params -> m (Maybe String) getLoggedInUser params = do - mbSd <- maybe (return Nothing) ( query . GetSession ) $ pSessionKey params + mbSd <- maybe (return Nothing) getSession $ pSessionKey params let user = case mbSd of Nothing -> Nothing Just sd -> Just $ sessionUser sd @@ -384,14 +394,14 @@ unlessNoEdit :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) unlessNoEdit responder = - \page params -> do cfg <- query GetConfig + \page params -> do cfg <- getConfig if page `elem` noEdit cfg then showPage page (params { pMessages = ("Page is locked." : pMessages params) }) else responder page params unlessNoDelete :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) unlessNoDelete responder = - \page params -> do cfg <- query GetConfig + \page params -> do cfg <- getConfig if page `elem` noDelete cfg then showPage page (params { pMessages = ("Page cannot be deleted." : pMessages params) }) else responder page params @@ -403,7 +413,7 @@ Nothing -> do loginUserForm page (params { pReferer = Just $ pUri params }) Just u -> do - usrs <- query AskUsers + usrs <- queryAppState users let e = case M.lookup u usrs of Just usr -> uEmail usr Nothing -> error $ "User '" ++ u ++ "' not found." @@ -428,7 +438,9 @@ Just ip -> ip Nothing -> "0.0.0.0" -- force ipaddr to be strictly evaluated, or we run into problems when validating captchas - ipaddr `seq` responder path' (params { pReferer = referer, pUri = uri, pIPAddress = ipaddr }) + ipaddr `seq` responder path' (params { pReferer = referer, + pUri = uri, + pIPAddress = ipaddr }) else noHandle ] else anyRequest noHandle @@ -465,15 +477,18 @@ Command (Just "showraw") -> [ handle isSourceCode GET showFileAsText ] _ -> [ handle isSourceCode GET showHighlightedSource ] + handleAny :: Handler handleAny = uriRest $ \uri -> let path' = uriPath uri - in do cfg <- query GetConfig - let file = repositoryPath cfg path' - exists <- liftIO $ doesFileExist file - if exists - then fileServe [path'] (repositoryPath cfg) - else anyRequest noHandle + in do fs <- getFileStore + mimetype <- getMimeTypeForExtension (takeExtension path') + res <- liftIO $ try $ (retrieve fs path' Nothing :: IO B.ByteString) + case res of + Right contents -> anyRequest $ ok $ setContentType mimetype $ + (toResponse noHtml) {rsBody = contents} -- ugly hack + Left NotFound -> anyRequest noHandle + Left e -> error (show e) orIfNull :: String -> String -> String orIfNull str backup = if null str then backup else str @@ -503,20 +518,6 @@ then page (intercalate "/" $ rqPaths req) req else noHandle -setContentType :: String -> Response -> Response -setContentType contentType res = - let respHeaders = rsHeaders res - newContentType = HeaderPair { hName = fromString "Content-Type", - hValue = [ fromString contentType ] } - in res { rsHeaders = M.insert (fromString "content-type") newContentType respHeaders } - -setFilename :: String -> Response -> Response -setFilename fname res = - let respHeaders = rsHeaders res - newContentType = HeaderPair { hName = fromString "Content-Disposition", - hValue = [ fromString $ "attachment; filename=\"" ++ fname ++ "\"" ] } - in res { rsHeaders = M.insert (fromString "content-disposition") newContentType respHeaders } - showRawPage :: String -> Params -> Web Response showRawPage = showFileAsText . pathForPage @@ -529,7 +530,8 @@ randomPage :: String -> Params -> Web Response randomPage _ _ = do - files <- gitListFiles "HEAD" + fs <- getFileStore + files <- liftIO $ index fs let pages = map dropExtension $ filter (\f -> takeExtension f == ".page" && not (":discuss.page" `isSuffixOf` f)) files if null pages then error "No pages found!" @@ -538,27 +540,39 @@ let newPage = pages !! ((fromIntegral picosecs `div` 1000000) `mod` length pages) seeOther (urlForPage newPage) $ toResponse $ p << "Redirecting to a random page" -showPage :: String -> Params -> Web Response -showPage "" params = do - cfg <- query GetConfig +showFrontPage :: String -> Params -> Web Response +showFrontPage _ params = do + cfg <- getConfig showPage (frontPage cfg) params + +showPage :: String -> Params -> Web Response showPage page params = do - let revision = pRevision params - mDoc <- pageAsPandoc page params - case mDoc of - Just d -> do - cont <- pandocToHtml d - let cont' = thediv ! [identifier "wikipage", - strAttr "onDblClick" ("window.location = '" ++ urlForPage page ++ - "?edit&revision=" ++ revision ++ - (if revision == "HEAD" - then "" - else '&' : urlEncodeVars [("logMsg", "Revert to " ++ revision)]) ++ "';")] << cont - formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js"]}) page params cont' - _ -> if revision == "HEAD" - then createPage page params - else error $ "Invalid revision: " ++ revision + jsMathExists <- queryAppState jsMath + mbCached <- lookupCache (pathForPage page) (pRevision params) + case mbCached of + Just cp -> + formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js" | jsMathExists]}) page params $ cpContents cp + _ -> do + mDoc <- pageAsPandoc page params + case mDoc of + Just d -> do + let divify c = thediv ! [identifier "wikipage", + strAttr "onDblClick" ("window.location = '" ++ urlForPage page ++ + "?edit" ++ + (case (pRevision params) of + Nothing -> "" + Just r -> urlEncodeVars [("revision", r),("logMsg", "Revert to " ++ r)]) ++ "';")] << c + c <- liftM divify $ pandocToHtml d + when (isNothing (pRevision params)) $ do + -- TODO not quite ideal, since page might have been modified after being retrieved by pageAsPandoc + -- better to have pageAsPandoc return the revision ID too... + fs <- getFileStore + rev <- liftIO $ latest fs (pathForPage page) + cacheContents (pathForPage page) rev c + formattedPage (defaultPageLayout { pgScripts = ["jsMath/easy/load.js" | jsMathExists]}) page params c + Nothing -> createPage page params + discussPage :: String -> Params -> Web Response discussPage page params = do if isDiscussPage page @@ -599,12 +613,14 @@ let fileContents = pFileContents params let wikiname = pWikiname params `orIfNull` takeFileName origPath let logMsg = pLogMsg params - cfg <- query GetConfig - let author = pUser params - when (null author) $ fail "User must be logged in to upload a file." - let email = pEmail params + cfg <- getConfig + mbUser <- getUser $ pUser params + (user, email) <- case mbUser of + Nothing -> fail "User must be logged in to delete page." + Just u -> return (uUsername u, uEmail u) let overwrite = pOverwrite params - exists <- liftIO $ doesFileExist (repositoryPath cfg wikiname) + fs <- getFileStore + exists <- liftIO $ catch (latest fs wikiname >> return True) (\e -> if e == NotFound then return False else throwIO e >> return True) let imageExtensions = [".png", ".jpg", ".gif"] let errors = validate [ (null logMsg, "Description cannot be empty.") , (null origPath, "File not found.") @@ -618,12 +634,7 @@ ] if null errors then do - 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 - gitCommit wikiname (author, email) logMsg + liftIO $ save fs wikiname (Author user email) logMsg fileContents formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Upload successful" }) page params $ thediv << [ h2 << ("Uploaded " ++ show (B.length fileContents) ++ " bytes") , if takeExtension wikiname `elem` imageExtensions @@ -633,16 +644,36 @@ pre << ("[link label](/" ++ wikiname ++ ")") ] else uploadForm page (params { pMessages = errors }) +goToPage :: String -> Params -> Web Response +goToPage _ params = do + let gotopage = pGotoPage params + fs <- getFileStore + allPageNames <- liftM (map dropExtension . filter (".page" `isSuffixOf`)) $ liftIO $ index fs + let findPage f = find f allPageNames + case findPage (gotopage ==) of + Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to exact match" + Nothing -> case findPage (\n -> (map toLower gotopage) == (map toLower n)) of + Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to case-insensitive match" + Nothing -> case findPage (\n -> (map toLower gotopage) `isPrefixOf` (map toLower n)) of + Just m -> seeOther (urlForPage m) $ toResponse "Redirecting to partial match" + Nothing -> searchResults "" params{ pPatterns = words gotopage } + searchResults :: String -> Params -> Web Response searchResults _ params = do let page = "_search" let patterns = pPatterns params let limit = pLimit params + fs <- getFileStore matchLines <- if null patterns then return [] - 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 + else liftM (take limit) $ liftIO $ search fs defaultSearchQuery{queryPatterns = patterns} + let contentMatches = map matchResourceName matchLines + allPages <- liftM (filter (".page" `isSuffixOf`)) $ liftIO $ index fs + let matchesPatterns pageName = all (`elem` (words $ map toLower $ dropExtension pageName)) $ map (map toLower) patterns + let pageNameMatches = filter matchesPatterns allPages + let allMatchedFiles = nub $ filter (".page" `isSuffixOf`) contentMatches ++ pageNameMatches + let matches = map (\f -> (f, mapMaybe (\x -> if matchResourceName x == f then Just (matchLine x) else Nothing) matchLines)) allMatchedFiles + let relevance (f, ms) = length ms + if f `elem` pageNameMatches then 100 else 0 let preamble = if null matches then h3 << if null patterns then ["Please enter a search term."] @@ -651,20 +682,16 @@ let htmlMatches = preamble +++ olist << map (\(file, contents) -> li << [anchor ! [href $ urlForPage $ takeBaseName file] << takeBaseName file, stringToHtml (" (" ++ show (length contents) ++ " matching lines)"), - stringToHtml " ", anchor ! [href "#", theclass "showmatch", thestyle "display: none;"] << "[show matches]", + stringToHtml " ", anchor ! [href "#", theclass "showmatch", thestyle "display: none;"] << + if length contents > 0 then "[show matches]" else "", pre ! [theclass "matches"] << unlines contents]) - (reverse $ sortBy (comparing (length . snd)) matches) + (reverse $ sortBy (comparing relevance) matches) formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgScripts = ["search.js"], pgTitle = "Search results"}) page params htmlMatches --- Auxiliary function for searchResults -parseMatchLine :: String -> (String, String) -parseMatchLine matchLine = - let (file, rest) = break (==':') matchLine - contents = drop 1 rest -- strip off colon - in (file, contents) - preview :: String -> Params -> Web Response -preview _ params = pandocToHtml (textToPandoc $ pRaw params) >>= ok . toResponse . encodeString . renderHtmlFragment +preview _ params = do + pt <- getDefaultPageType -- should get the current page type instead + pandocToHtml (textToPandoc pt $ pRaw params) >>= ok . toResponse . encodeString . renderHtmlFragment showPageHistory :: String -> Params -> Web Response showPageHistory page params = showHistory (pathForPage page) page params @@ -674,27 +701,32 @@ showHistory :: String -> String -> Params -> Web Response showHistory file page params = do - let since = pSince params `orIfNull` "1 year ago" - hist <- gitLog since "" [file] + currTime <- liftIO getCurrentTime + let oneYearAgo = addMinutes (-1 * 60 * 24 * 365) currTime + let since = case pSince params of + Nothing -> Just oneYearAgo + Just t -> Just t + fs <- getFileStore + hist <- liftIO $ history fs [file] (TimeRange since Nothing) if null hist then noHandle else do - let versionToHtml entry pos = - li ! [theclass "difflink", intAttr "order" pos, strAttr "revision" $ logRevision entry] << - [thespan ! [theclass "date"] << logDate entry, stringToHtml " (", + let versionToHtml rev pos = + li ! [theclass "difflink", intAttr "order" pos, strAttr "revision" $ revId rev] << + [thespan ! [theclass "date"] << (show $ revDateTime rev), stringToHtml " (", thespan ! [theclass "author"] << - anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", logAuthor entry)]] << - (logAuthor entry), stringToHtml ")", stringToHtml ": ", - anchor ! [href (urlForPage page ++ "?revision=" ++ logRevision entry)] << - thespan ! [theclass "subject"] << logSubject entry, + anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", authorName $ revAuthor rev)]] << + (authorName $ revAuthor rev), stringToHtml ")", stringToHtml ": ", + anchor ! [href (urlForPage page ++ "?revision=" ++ revId rev)] << + thespan ! [theclass "subject"] << revDescription rev, noscript << ([stringToHtml " [compare with ", - anchor ! [href $ urlForPage page ++ "?diff&from=" ++ logRevision entry ++ - "^&to=" ++ logRevision entry] << "previous"] ++ + anchor ! [href $ urlForPage page ++ "?diff&from=" ++ revId rev ++ + "^&to=" ++ revId rev] << "previous"] ++ (if pos /= 1 then [primHtmlChar "nbsp", primHtmlChar "bull", primHtmlChar "nbsp", anchor ! [href $ urlForPage page ++ "?diff&from=" ++ - logRevision entry ++ "&to=HEAD"] << "current" ] + revId rev ++ "&to=HEAD"] << "current" ] else []) ++ [stringToHtml "]"])] let contents = ulist ! [theclass "history"] << zipWith versionToHtml hist [(length hist), (length hist - 1)..1] @@ -703,20 +735,28 @@ showActivity :: String -> Params -> Web Response showActivity _ params = do let page = "_activity" - let since = pSince params `orIfNull` "1 month ago" + currTime <- liftIO getCurrentTime + let oneMonthAgo = addMinutes (-1 * 60 * 24 * 30) currTime + let since = case pSince params of + Nothing -> Just oneMonthAgo + Just t -> Just t let forUser = pForUser params - hist <- gitLog since forUser [] - let filesFor files revis = intersperse (primHtmlChar "nbsp") $ map - (\file -> anchor ! [href $ urlForPage file ++ "?diff&from=" ++ revis ++ "^" ++ "&to=" ++ revis] << file) $ map - (\file -> if ".page" `isSuffixOf` file then dropExtension file else file) files + fs <- getFileStore + hist <- liftIO $ history fs [] (TimeRange since Nothing) + let fileFromChange (Added f) = f + fileFromChange (Modified f) = f + fileFromChange (Deleted f) = f + let filesFor changes revis = intersperse (primHtmlChar "nbsp") $ map + (\file -> anchor ! [href $ urlForPage file ++ "?diff&to=" ++ revis] << file) $ map + (\file -> if ".page" `isSuffixOf` file then dropExtension file else file) $ map fileFromChange changes let heading = h1 << ("Recent changes" ++ if null forUser then "" else (" by " ++ forUser)) - let contents = ulist ! [theclass "history"] << map (\entry -> li << - [thespan ! [theclass "date"] << logDate entry, stringToHtml " (", + let contents = ulist ! [theclass "history"] << map (\rev -> li << + [thespan ! [theclass "date"] << (show $ revDateTime rev), stringToHtml " (", thespan ! [theclass "author"] << - anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", logAuthor entry)]] << - (logAuthor entry), stringToHtml "): ", - thespan ! [theclass "subject"] << logSubject entry, stringToHtml " (", - thespan ! [theclass "files"] << filesFor (logFiles entry) (logRevision entry), + anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", authorName $ revAuthor rev)]] << + (authorName $ revAuthor rev), stringToHtml "): ", + thespan ! [theclass "subject"] << revDescription rev, stringToHtml " (", + thespan ! [theclass "files"] << filesFor (revChanges rev) (revId rev), stringToHtml ")"]) hist formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Recent changes" }) page params (heading +++ contents) @@ -730,34 +770,52 @@ showDiff file page params = do let from = pFrom params let to = pTo params - rawDiff <- gitDiff file from to - let diffLineToHtml l = case head l of - '+' -> thespan ! [theclass "added"] << [tail l, "\n"] - '-' -> thespan ! [theclass "deleted"] << [tail l, "\n"] - _ -> thespan << [tail l, "\n"] - let formattedDiff = h2 ! [theclass "revision"] << ("Changes from " ++ from) +++ - pre ! [theclass "diff"] << map diffLineToHtml (drop 5 $ lines rawDiff) + fs <- getFileStore + from' <- case from of + Nothing -> do + pageHist <- liftIO $ history fs [pathForPage page] (TimeRange Nothing Nothing) + if length pageHist < 2 + then return Nothing + else case to of + Nothing -> return Nothing + Just t -> let (_, upto) = break (\r -> idsMatch fs (revId r) t) pageHist + in return $ + if length upto >= 2 + then Just $ revId $ upto !! 1 -- the immediately preceding revision + else Nothing + x -> return x + rawDiff <- liftIO $ diff fs file from' to + let diffItemToHtml (B, xs) = thespan << xs + diffItemToHtml (F, xs) = thespan ! [theclass "deleted"] << xs + diffItemToHtml (S, xs) = thespan ! [theclass "added"] << xs + let formattedDiff = h2 ! [theclass "revision"] << ("Changes from " ++ case from' of { Just r -> r; Nothing -> "beginning" }) +++ + pre ! [theclass "diff"] << map diffItemToHtml rawDiff formattedPage (defaultPageLayout { pgTabs = DiffTab : pgTabs defaultPageLayout, pgSelectedTab = DiffTab }) page (params { pRevision = to }) formattedDiff editPage :: String -> Params -> Web Response editPage page params = do - let revision = pRevision params + let rev = pRevision params let messages = pMessages params - raw <- case pEditedText params of - Nothing -> gitCatFile revision (pathForPage page) - Just t -> return $ Just t - let contents = case raw of - Nothing -> "" - Just c -> c - sha1 <- case (pSHA1 params) of - "" -> gitGetSHA1 (pathForPage page) >>= return . fromMaybe "" - s -> return s + fs <- getFileStore + (mbRev, raw) <- case pEditedText params of + Nothing -> liftIO $ catch + (do c <- liftIO $ retrieve fs (pathForPage page) rev + r <- liftIO $ case rev of + Nothing -> latest fs (pathForPage page) >>= revision fs + Just r -> revision fs r + return $ (Just $ revId r, c)) + (\e -> if e == NotFound + then return (Nothing, "") + else throwIO e) + Just t -> return (if null (pSHA1 params) then Nothing else Just (pSHA1 params), t) let logMsg = pLogMsg params - let sha1Box = textfield "sha1" ! [thestyle "display: none", value sha1] + let sha1Box = case mbRev of + Just r -> textfield "sha1" ! [thestyle "display: none", value r] + Nothing -> noHtml let editForm = gui (urlForPage page) ! [identifier "editform"] << [sha1Box, - textarea ! [cols "80", name "editedText", identifier "editedText"] << contents, br, + textarea ! [cols "80", name "editedText", identifier "editedText"] << raw, br, label << "Description of changes:", br, textfield "logMsg" ! [value logMsg], submit "update" "Save", primHtmlChar "nbsp", @@ -780,66 +838,62 @@ deletePage :: String -> Params -> Web Response deletePage page params = do + mbUser <- getUser $ pUser params + (user, email) <- case mbUser of + Nothing -> fail "User must be logged in to delete page." + Just u -> return (uUsername u, uEmail u) if pConfirm params then do - let author = pUser params - when (null author) $ fail "User must be logged in to delete page." - let email = pEmail params - gitRemove (pathForPage page) (author, email) "Deleted from web." + fs <- getFileStore + liftIO $ delete fs (pathForPage page) (Author user email) "Deleted using web interface." seeOther "/" $ toResponse $ p << "Page deleted" else seeOther (urlForPage page) $ toResponse $ p << "Page not deleted" updatePage :: String -> Params -> Web Response updatePage page params = do - let author = pUser params - when (null author) $ fail "User must be logged in to update page." + mbUser <- getUser $ pUser params + (user, email) <- case mbUser of + Nothing -> fail "User must be logged in to delete page." + Just u -> return (uUsername u, uEmail u) let editedText = case pEditedText params of Nothing -> error "No body text in POST request" Just b -> b - let email = pEmail params let logMsg = pLogMsg params let oldSHA1 = pSHA1 params + fs <- getFileStore if null logMsg then editPage page (params { pMessages = ["Description cannot be empty."] }) else do - cfg <- query GetConfig + cfg <- getConfig if length editedText > fromIntegral (maxUploadSize cfg) then error "Page exceeds maximum size." else return () - currentSHA1 <- gitGetSHA1 (pathForPage page) >>= return . fromMaybe "" -- ensure that every file has a newline at the end, to avoid "No newline at eof" messages in diffs let editedText' = if null editedText || last editedText == '\n' then editedText else editedText ++ "\n" -- check SHA1 in case page has been modified, merge - if currentSHA1 == oldSHA1 - then do - let dir' = takeDirectory page - liftIO $ createDirectoryIfMissing True ((repositoryPath cfg) dir') - liftIO $ writeFile ((repositoryPath cfg) pathForPage page) editedText' - gitCommit (pathForPage page) (author, email) logMsg - seeOther (urlForPage page) $ toResponse $ p << "Page updated" - else do -- there have been conflicting changes - original <- gitCatFile oldSHA1 (pathForPage page) >>= return . fromJust - latest <- gitCatFile currentSHA1 (pathForPage page) >>= return . fromJust - let pagePath = repositoryPath cfg pathForPage page - let [textTmp, originalTmp, latestTmp] = map (pagePath ++) [".edited",".original",".latest"] - liftIO $ writeFile textTmp editedText' - liftIO $ writeFile originalTmp original - liftIO $ writeFile latestTmp latest - mergeText <- gitMergeFile (pathForPage page ++ ".edited") (pathForPage page ++ ".original") (pathForPage page ++ ".latest") - liftIO $ mapM removeFile [textTmp, originalTmp, latestTmp] - let mergeMsg = "The page has been edited since you checked it out. " ++ - "Changes have been merged into your edits below. " ++ - "Please resolve conflicts and Save." - editPage page (params { pEditedText = Just mergeText - , pRevision = "HEAD" - , pSHA1 = currentSHA1 - , pMessages = [mergeMsg] }) + modifyRes <- if null oldSHA1 + then liftIO $ create fs (pathForPage page) (Author user email) logMsg editedText' >> return (Right ()) + else liftIO $ catch (modify fs (pathForPage page) oldSHA1 (Author user email) logMsg editedText') + (\e -> if e == Unchanged then return (Right ()) else throwIO e) + case modifyRes of + Right () -> seeOther (urlForPage page) $ toResponse $ p << "Page updated" + Left (MergeInfo mergedWithRev False mergedText) -> + updatePage page params{ pMessages = ("Merged with revision " ++ revId mergedWithRev) : pMessages params, + pEditedText = Just mergedText, + pSHA1 = revId mergedWithRev } + Left (MergeInfo mergedWithRev True mergedText) -> do + let mergeMsg = "The page has been edited since you checked it out. " ++ + "Changes have been merged into your edits below. " ++ + "Please resolve conflicts and Save." + editPage page (params { pEditedText = Just mergedText + , pSHA1 = revId mergedWithRev + , pMessages = [mergeMsg] }) indexPage :: String -> Params -> Web Response indexPage _ params = do let page = "_index" - let revision = pRevision params - files <- gitListFiles revision + fs <- getFileStore + files <- liftIO $ index fs 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 @@ -880,7 +934,7 @@ -- | Converts pandoc document to HTML. pandocToHtml :: MonadIO m => Pandoc -> m Html pandocToHtml pandocContents = do - cfg <- query GetConfig + cfg <- getConfig return $ writeHtml (defaultWriterOptions { writerStandalone = False , writerHTMLMathMethod = JsMath (Just "/js/jsMath/easy/load.js") , writerTableOfContents = tableOfContents cfg @@ -909,11 +963,15 @@ -- | Returns formatted page formattedPage :: PageLayout -> String -> Params -> Html -> Web Response formattedPage layout page params htmlContents = do - let revision = pRevision params - let path' = if isPage page then pathForPage page else page - sha1 <- if revision == "HEAD" - then gitGetSHA1 path' >>= return . fromMaybe "" - else return revision + let rev = pRevision params + let path' = if isPage page then pathForPage page else page + fs <- getFileStore + sha1 <- case rev of + Nothing -> liftIO $ catch (latest fs path') + (\e -> if e == NotFound + then return "" + else throwIO e) + Just r -> return r user <- getLoggedInUser params let javascriptlinks = if null (pgScripts layout) then "" @@ -925,30 +983,37 @@ then li ! [theclass "selected"] else li let origPage s = if ":discuss" `isSuffixOf` s then take (length s - 8) s else s - let linkForTab HistoryTab = Just $ tabli HistoryTab << anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&history"] << "history" + let linkForTab HistoryTab = Just $ tabli HistoryTab << anchor ! [href $ urlForPage page ++ "?history" ++ + case rev of { Just r -> "&revision" ++ r; Nothing -> "" }] << "history" linkForTab DiffTab = Just $ tabli DiffTab << anchor ! [href ""] << "diff" linkForTab ViewTab = if isDiscussPage page then Just $ tabli DiscussTab << anchor ! [href $ urlForPage $ origPage page] << "page" - else Just $ tabli ViewTab << anchor ! [href $ urlForPage page ++ if revision == "HEAD" then "" else "?revision=" ++ revision] << "view" + else Just $ tabli ViewTab << anchor ! [href $ urlForPage page ++ + case rev of { Just r -> "?revision=" ++ r; Nothing -> "" }] << "view" linkForTab DiscussTab = if isDiscussPage page then Just $ tabli ViewTab << anchor ! [href $ urlForPage page] << "discuss" else if isPage page then Just $ tabli DiscussTab << anchor ! [href $ urlForPage page ++ "?discuss"] << "discuss" else Nothing linkForTab EditTab = if isPage page - then Just $ tabli EditTab << anchor ! [href $ urlForPage page ++ "?edit&revision=" ++ revision ++ - if revision == "HEAD" then "" else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)]] << - if revision == "HEAD" then "edit" else "revert" + then Just $ tabli EditTab << anchor ! [href $ urlForPage page ++ "?edit" ++ + (case rev of + Just r -> "&revision=" ++ r ++ "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ r)] + Nothing -> "")] << + if isNothing rev then "edit" else "revert" else Nothing let tabs = ulist ! [theclass "tabs"] << mapMaybe linkForTab (pgTabs layout) let searchbox = gui ("/_search") ! [identifier "searchform"] << [ textfield "patterns" , submit "search" "Search" ] + let gobox = gui ("/_go") ! [identifier "goform"] << + [ textfield "gotopage" + , submit "go" "Go" ] let messages = pMessages params let htmlMessages = if null messages then noHtml else ulist ! [theclass "messages"] << map (li <<) messages - templ <- liftIO $ readIORef template + templ <- queryAppState template let filledTemp = T.render $ T.setAttribute "pagetitle" pageTitle $ T.setAttribute "javascripts" javascriptlinks $ @@ -959,10 +1024,10 @@ (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 $ + (if isJust rev then T.setAttribute "nothead" "true" else id) $ + (if isJust rev then T.setAttribute "revision" (fromJust rev) else id) $ T.setAttribute "sha1" sha1 $ - T.setAttribute "searchbox" (renderHtmlFragment searchbox) $ + T.setAttribute "searchbox" (renderHtmlFragment (searchbox +++ gobox)) $ T.setAttribute "exportbox" (renderHtmlFragment $ exportBox page params) $ T.setAttribute "tabs" (renderHtmlFragment tabs) $ T.setAttribute "messages" (renderHtmlFragment htmlMessages) $ @@ -994,10 +1059,10 @@ let uname = pUsername params let pword = pPassword params let destination = pDestination params - allowed <- query $ AuthUser uname pword + allowed <- authUser uname pword if allowed then do - key <- update $ NewSession (SessionData uname) + key <- newSession (SessionData uname) addCookie sessionTime (mkCookie "sid" (show key)) addCookie 0 (mkCookie "destination" "") -- remove unneeded destination cookie seeOther destination $ toResponse $ p << ("Welcome, " ++ uname) @@ -1010,14 +1075,14 @@ let destination = substitute " " "%20" $ fromMaybe "/" $ pReferer params case key of Just k -> do - update $ DelSession k + delSession k addCookie 0 (mkCookie "sid" "") -- make cookie expire immediately, effectively deleting it Nothing -> return () seeOther destination $ toResponse "You have been logged out." registerForm :: Web Html registerForm = do - cfg <- query GetConfig + cfg <- getConfig let accessQ = case accessQuestion cfg of Nothing -> noHtml Just (prompt, _) -> label << prompt +++ br +++ @@ -1055,8 +1120,8 @@ let email = pEmail params let fakeField = pFullName params let recaptcha = pRecaptcha params - taken <- query $ IsUser uname - cfg <- query GetConfig + taken <- isUser uname + cfg <- getConfig let isValidAccessCode = case accessQuestion cfg of Nothing -> True Just (_, answers) -> accessCode `elem` answers @@ -1081,7 +1146,7 @@ if null errors then do user <- liftIO $ mkUser uname email pword - update $ AddUser uname user + addUser uname user loginUser "/" (params { pUsername = uname, pPassword = pword, pEmail = email }) else registerForm >>= formattedPage (defaultPageLayout { pgShowPageTools = False, pgTabs = [], pgTitle = "Register for an account" }) @@ -1089,13 +1154,23 @@ showHighlightedSource :: String -> Params -> Web Response showHighlightedSource file params = do - contents <- rawContents file params - case contents of - Just source -> let lang' = head $ languagesByExtension $ takeExtension file - in case highlightAs lang' (filter (/='\r') source) of - Left _ -> noHandle - Right res -> formattedPage defaultPageLayout file params $ formatAsXHtml [OptNumberLines] lang' res - Nothing -> noHandle + mbCached <- lookupCache file (pRevision params) + case mbCached of + Just cp -> formattedPage defaultPageLayout file params $ cpContents cp + _ -> do + contents <- rawContents file params + case contents of + Just source -> let lang' = head $ languagesByExtension $ takeExtension file + in case highlightAs lang' (filter (/='\r') source) of + Left _ -> noHandle + Right res -> do + let formattedContents = formatAsXHtml [OptNumberLines] lang' res + when (isNothing (pRevision params)) $ do + fs <- getFileStore + rev <- liftIO $ latest fs file + cacheContents file rev formattedContents + formattedPage defaultPageLayout file params $ formattedContents + Nothing -> noHandle defaultRespOptions :: WriterOptions defaultRespOptions = defaultWriterOptions { writerStandalone = True, writerWrapText = True } @@ -1138,11 +1213,14 @@ respondODT :: String -> Pandoc -> Web Response respondODT page doc = do - cfg <- query GetConfig let openDoc = writeOpenDocument (defaultRespOptions {writerHeader = defaultOpenDocumentHeader}) doc contents <- liftIO $ withTempDir "gitit-temp-odt" $ \tempdir -> do let tempfile = tempdir page <.> "odt" - saveOpenDocumentAsODT tempfile (repositoryPath cfg) openDoc + conf <- getConfig + let repoPath = case repository conf of + Git path' -> path' + Darcs path' -> path' + saveOpenDocumentAsODT tempfile repoPath openDoc B.readFile tempfile ok $ setContentType "application/vnd.oasis.opendocument.text" $ setFilename (page ++ ".odt") $ (toResponse noHtml) {rsBody = contents} @@ -1160,30 +1238,38 @@ exportBox :: String -> Params -> Html exportBox page params | isPage page = - gui (urlForPage page) ! [identifier "exportbox"] << - [ textfield "revision" ! [thestyle "display: none;", value (pRevision params)] - , select ! [name "format"] << - map ((\f -> option ! [value f] << f) . fst) exportFormats - , submit "export" "Export" ] + let rev = pRevision params + in gui (urlForPage page) ! [identifier "exportbox"] << + ([ textfield "revision" ! [thestyle "display: none;", value (fromJust rev)] | isJust rev ] ++ + [ select ! [name "format"] << + map ((\f -> option ! [value f] << f) . fst) exportFormats + , submit "export" "Export" ]) exportBox _ _ = noHtml rawContents :: String -> Params -> Web (Maybe String) rawContents file params = do - let revision = pRevision params `orIfNull` "HEAD" - gitCatFile revision file + let rev = pRevision params + fs <- getFileStore + liftIO $ catch (retrieve fs file rev >>= return . Just) (\e -> if e == NotFound then return Nothing else throwIO e) +{- removeRawHtmlBlock :: Block -> Block removeRawHtmlBlock (RawHtml _) = RawHtml "" removeRawHtmlBlock x = x +-} -textToPandoc :: String -> Pandoc -textToPandoc = processPandoc removeRawHtmlBlock . - readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) . - filter (/= '\r') +readerFor :: PageType -> (String -> Pandoc) +readerFor pt = case pt of + RST -> readRST (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) + Markdown -> readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) +textToPandoc :: PageType -> String -> Pandoc +textToPandoc pt s = {- processPandoc removeRawHtmlBlock $ -} readerFor pt $ filter (/= '\r') s + pageAsPandoc :: String -> Params -> Web (Maybe Pandoc) pageAsPandoc page params = do - mDoc <- rawContents (pathForPage page) params >>= (return . liftM textToPandoc) + pt <- getDefaultPageType + mDoc <- rawContents (pathForPage page) params >>= (return . liftM (textToPandoc pt)) return $ case mDoc of Nothing -> Nothing Just (Pandoc _ blocks) -> Just $ Pandoc (Meta [Str page] [] []) blocks @@ -1205,9 +1291,9 @@ -- | Create a temporary directory with a unique name. createTempDir :: Integer -> FilePath -> IO FilePath createTempDir num baseName = do - sysTempDir <- catch getTemporaryDirectory (\_ -> return ".") + sysTempDir <- getTemporaryDirectory let dirName = sysTempDir baseName <.> show num - catch (createDirectory dirName >> return dirName) $ + liftIO $ catch (createDirectory dirName >> return dirName) $ \e -> if isAlreadyExistsError e then createTempDir (num + 1) baseName else ioError e diff --git a/Gitit/Git.hs b/Gitit/Git.hs deleted file mode 100644 --- a/Gitit/Git.hs +++ /dev/null @@ -1,224 +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 --} - -{- Auxiliary functions for running git commands. - - Note: UTF-8 locale is assumed. --} - -module Gitit.Git - ( runGitCommand - , gitLastCommitHash - , gitLog - , gitListFiles - , gitGrep - , gitCatFile - , gitDiff - , gitCommit - , gitRemove - , gitGetSHA1 - , gitMergeFile - , LogEntry (..) ) -where - -import Control.Monad (unless, liftM) -import Control.Monad.Trans -import Network.CGI (urlEncode) -import System.Exit -import qualified Text.ParserCombinators.Parsec as P -import Prelude hiding (readFile, writeFile) -import Codec.Binary.UTF8.String (decodeString) -import HAppS.State -import Gitit.Shell (runProgCommand) -import Gitit.State -import Data.Char (chr) - --- | 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) - 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) -gitLastCommitHash filename = do - (status, _, output) <- runGitCommand "log" $ ["--pretty=format:%H", "--"] ++ [filename] - let outputWords = words output - if status == ExitSuccess && not (null outputWords) - then return $ Just $ head outputWords - else return Nothing - --- | Return list of log entries for the given time frame and commit author. --- If author is null, return entries for all authors. -gitLog :: MonadIO m => String -> String -> [String] -> m [LogEntry] -gitLog since author files = do - (status, err, output) <- runGitCommand "whatchanged" $ ["--pretty=format:%h%n%cr%n%an%n%s%n"] ++ - ["--since='" ++ urlEncode since ++ "'"] ++ - (if null author then [] else ["--author=" ++ author]) ++ - ["--"] ++ files - if status == ExitSuccess - then case P.parse parseGitLog "" output of - Left err' -> error $ show err' - Right parsed -> return parsed - else error $ "git whatchanged returned error status.\n" ++ err - -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 - 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"] ++ - concatMap (\term -> ["-e", term]) patterns) - if status == ExitSuccess - then return output - else error $ "git grep returned error status.\n" ++ errOutput - -gitCatFile :: MonadIO m => String -> FilePath -> m (Maybe String) -gitCatFile revision file = do - (status, _, output) <- runGitCommand "cat-file" ["-p", revision ++ ":" ++ file] - return $ if status == ExitSuccess - then Just output - else Nothing - -gitDiff :: MonadIO m - => String -- ^ Filename - -> String -- ^ Old version (sha1) - -> String -- ^ New version (sha1) - -> m String -- ^ String -gitDiff file from to = do - (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') <- runGitCommand "diff" [from, to] - if status' == ExitSuccess - then return output' - else error $ "git diff returned error: " ++ errOut' - --- | Add and then commit file, raising errors if either step fails. -gitCommit :: MonadIO m => FilePath -> (String, String) -> String -> m () -gitCommit file (author, email) logMsg = do - (statusAdd, errAdd, _) <- runGitCommand "add" [file] - if statusAdd == ExitSuccess - then do (statusCommit, errCommit, _) <- runGitCommand "commit" ["--author", author ++ " <" ++ - email ++ ">", "-m", logMsg] - if statusCommit == ExitSuccess - then return () - else unless (null errCommit) $ error $ "Could not git commit " ++ file ++ "\n" ++ errCommit - else error $ "Could not git add " ++ file ++ "\n" ++ errAdd - --- | Remove file from repository and commit, raising errors if either step fails. -gitRemove :: MonadIO m => FilePath -> (String, String) -> String -> m () -gitRemove file (author, email) logMsg = do - (statusAdd, errAdd, _) <- runGitCommand "rm" [file] - if statusAdd == ExitSuccess - then do (statusCommit, errCommit, _) <- runGitCommand "commit" ["--author", author ++ " <" ++ - email ++ ">", "-m", logMsg] - if statusCommit == ExitSuccess - then return () - else unless (null errCommit) $ error $ "Could not git commit " ++ file ++ "\n" ++ errCommit - else error $ "Could not git rm " ++ file ++ "\n" ++ errAdd - -gitGetSHA1 :: MonadIO m => FilePath -> m (Maybe String) -gitGetSHA1 file = do - (status, _, out) <- runGitCommand "log" ["-n", "1", "--pretty=oneline", file] - if status == ExitSuccess && length out > 0 - then return $ Just $ head $ words out - else return $ Nothing - -gitMergeFile :: MonadIO m => FilePath -> FilePath -> FilePath -> m String -gitMergeFile edited original latest = do - (status, err, out) <- runGitCommand "merge-file" ["--stdout", edited, original, latest] - case status of - ExitSuccess -> return out - ExitFailure n | n >= 0 -> return out -- indicates number of merge conflicts - _ -> error $ "git merge-file returned an error.\n" ++ err - --- --- Parsers to parse git log into LogEntry records. --- - --- | Abstract representation of a git log entry. -data LogEntry = LogEntry - { logRevision :: String - , logDate :: String - , logAuthor :: String - , logSubject :: String - , logFiles :: [String] - } deriving (Read, Show) - -parseGitLog :: P.Parser [LogEntry] -parseGitLog = P.manyTill gitLogEntry P.eof - -wholeLine :: P.GenParser Char st [Char] -wholeLine = P.manyTill P.anyChar P.newline - -nonblankLine :: P.GenParser Char st [Char] -nonblankLine = P.notFollowedBy P.newline >> wholeLine - -gitLogEntry :: P.Parser LogEntry -gitLogEntry = do - rev <- nonblankLine - date <- nonblankLine - author <- wholeLine - subject <- liftM unlines (P.manyTill wholeLine (P.eof P.<|> (P.lookAhead (P.char ':') >> return ()))) - P.spaces - files <- P.many gitLogChange - P.spaces - return $ LogEntry { logRevision = rev, - logDate = date, - logAuthor = author, - logSubject = subject, - logFiles = map convertEncoded files } - -gitLogChange :: P.Parser String -gitLogChange = do - P.char ':' - line <- nonblankLine - return $ unwords $ drop 5 $ words line diff --git a/Gitit/MimeTypes.hs b/Gitit/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/Gitit/MimeTypes.hs @@ -0,0 +1,39 @@ +{- +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 +-} + +{- Mapping from file extensions to mime types. +-} + +module Gitit.MimeTypes ( readMimeTypesFile ) +where +import qualified Data.Map as M +import qualified HAppS.Server +import System.IO (stderr, hPutStrLn) + +-- | Read a file associating mime types with extensions, and return a +-- map from extensions to types. Each line of the file consists of a +-- mime type, followed by space, followed by a list of zero or more +-- extensions, separated by spaces. Example: text/plain txt text +readMimeTypesFile :: FilePath -> IO (M.Map String String) +readMimeTypesFile f = catch (readFile f >>= return . foldr go M.empty . map words . lines) $ + handleMimeTypesFileNotFound + where go [] m = m -- skip blank lines + go (x:xs) m = foldr (\ext m' -> M.insert ext x m') m xs + handleMimeTypesFileNotFound e = do + hPutStrLn stderr $ "Could not read mime types file: " ++ f + hPutStrLn stderr $ show e + hPutStrLn stderr $ "Using defaults instead." + return HAppS.Server.mimeTypes + diff --git a/Gitit/Shell.hs b/Gitit/Shell.hs deleted file mode 100644 --- a/Gitit/Shell.hs +++ /dev/null @@ -1,51 +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 --} - -{- 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 @@ -1,7 +1,3 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE TemplateHaskell , FlexibleInstances, - UndecidableInstances, OverlappingInstances, - MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {- Copyright (C) 2008 John MacFarlane @@ -21,26 +17,67 @@ -} {- Functions for maintaining user list and session state. - Parts of this code are based on http://hpaste.org/5957 mightybyte rev by - dbpatterson. -} module Gitit.State where import qualified Data.Map as M -import Control.Monad.Reader -import Control.Monad.State (modify, MonadState) -import Data.Generics -import HAppS.State -import HAppS.Data -import GHC.Conc (STM) import System.Random (randomRIO) import Data.Digest.Pure.SHA (sha512, showDigest) import qualified Data.ByteString.Lazy.UTF8 as L (fromString) +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO(), liftIO) +import Control.Monad (replicateM, liftM) +import Control.Exception (try, throwIO) +import Data.FileStore +import Gitit.MimeTypes (readMimeTypesFile) +import Data.List (intercalate) +import Data.Char (toLower) +import Text.XHtml (Html) +import qualified Text.StringTemplate as T +appstate :: IORef AppState +appstate = unsafePerformIO $ newIORef $ AppState { sessions = undefined + , users = undefined + , config = undefined + , filestore = undefined + , mimeMap = undefined + , cache = undefined + , template = undefined + , jsMath = undefined } + +initializeAppState :: MonadIO m => Config -> M.Map String User -> T.StringTemplate String -> m () +initializeAppState conf users' templ = do + mimeMapFromFile <- liftIO $ readMimeTypesFile (mimeTypesFile conf) + updateAppState $ \s -> s { sessions = Sessions M.empty + , users = users' + , config = conf + , filestore = case repository conf of + Git fs -> gitFileStore fs + Darcs fs -> darcsFileStore fs + , mimeMap = mimeMapFromFile + , cache = M.empty + , template = templ + , jsMath = False } + +updateAppState :: MonadIO m => (AppState -> AppState) -> m () +updateAppState fn = liftIO $! atomicModifyIORef appstate $ \st -> (fn st, ()) + +queryAppState :: MonadIO m => (AppState -> a) -> m a +queryAppState fn = liftIO $! readIORef appstate >>= return . fn + +data Repository = Git FilePath + | Darcs FilePath + deriving (Read, Show) + +data PageType = Markdown | RST + deriving (Read, Show) + -- | Data structure for information read from config file. data Config = Config { - repositoryPath :: FilePath, -- path of git repository for pages + repository :: Repository, -- file store for pages + defaultPageType :: PageType, -- the default page markup type for this wiki userFile :: FilePath, -- path of users database templateFile :: FilePath, -- path of page template file staticDir :: FilePath, -- path of static directory @@ -56,12 +93,14 @@ -- and must give one of the answers in order to register. useRecaptcha :: Bool, -- use ReCAPTCHA service to provide captchas for user registration. recaptchaPublicKey :: String, - recaptchaPrivateKey :: String - } deriving (Read, Show,Eq,Typeable,Data) + recaptchaPrivateKey :: String, + mimeTypesFile :: FilePath -- path of file associating mime types with file extensions + } deriving (Read, Show) defaultConfig :: Config defaultConfig = Config { - repositoryPath = "wikidata", + repository = Git "wikidata", + defaultPageType = Markdown, userFile = "gitit-users", templateFile = "template.html", staticDir = "static", @@ -75,71 +114,73 @@ accessQuestion = Nothing, useRecaptcha = False, recaptchaPublicKey = "", - recaptchaPrivateKey = "" + recaptchaPrivateKey = "", + mimeTypesFile = "/etc/mime.types" } +data CachedPage = CachedPage { + cpContents :: Html + , cpRevisionId :: RevisionId + } deriving Show + type SessionKey = Integer data SessionData = SessionData { sessionUser :: String -} deriving (Read,Show,Eq,Typeable,Data) +} deriving (Read,Show,Eq) data Sessions a = Sessions {unsession::M.Map SessionKey a} - deriving (Read,Show,Eq,Typeable,Data) + deriving (Read,Show,Eq) -- Password salt hashedPassword data Password = Password { pSalt :: String, pHashed :: String } - deriving (Read,Show,Eq,Typeable,Data) + deriving (Read,Show,Eq) data User = User { uUsername :: String, uPassword :: Password, uEmail :: String -} deriving (Show,Read,Typeable,Data) +} deriving (Show,Read) data AppState = AppState { - sessions :: Sessions SessionData, - users :: M.Map String User, - config :: Config -} deriving (Show,Read,Typeable,Data) - -instance Version SessionData -instance Version (Sessions a) -instance Version Config - -$(deriveSerialize ''SessionData) -$(deriveSerialize ''Sessions) -$(deriveSerialize ''Config) - -instance Version AppState -instance Version User -instance Version Password - -$(deriveSerialize ''Password) -$(deriveSerialize ''User) -$(deriveSerialize ''AppState) - -instance Component AppState where - type Dependencies AppState = End - initialValue = AppState {sessions = (Sessions M.empty), users = M.empty, config = defaultConfig} - -askUsers :: MonadReader AppState m => m (M.Map String User) -askUsers = return . users =<< ask - -askSessions::MonadReader AppState m => m (Sessions SessionData) -askSessions = return . sessions =<< ask - -setUsers :: MonadState AppState m => M.Map String User -> m () -setUsers newusers = modify $ \s -> s {users = newusers} - -modUsers :: MonadState AppState m => (M.Map String User -> M.Map String User) -> m () -modUsers f = modify $ \s -> s {users = f $ users s} + sessions :: Sessions SessionData, + users :: M.Map String User, + config :: Config, + filestore :: FileStore, + mimeMap :: M.Map String String, + cache :: M.Map String CachedPage, + template :: T.StringTemplate String, + jsMath :: Bool +} -modSessions :: MonadState AppState m => (Sessions SessionData -> Sessions SessionData) -> m () -modSessions f = modify $ \s -> s {sessions = f $ sessions s} +lookupCache :: MonadIO m => String -> (Maybe RevisionId) -> m (Maybe CachedPage) +lookupCache file (Just revid) = do + c <- queryAppState cache + fs <- getFileStore + case M.lookup file c of + Just cp | idsMatch fs (cpRevisionId cp) revid -> + return $ Just cp + _ -> return Nothing +lookupCache file Nothing = do + fs <- getFileStore + latestRes <- liftIO $ try (latest fs file) + case latestRes of + Right latestid -> do + c <- queryAppState cache + case M.lookup file c of + Just cp | idsMatch fs (cpRevisionId cp) latestid -> + return $ Just cp + _ -> return Nothing + Left NotFound -> return Nothing + Left e -> liftIO $ throwIO e -isUser :: MonadReader AppState m => String -> m Bool -isUser name = liftM (M.member name) askUsers +cacheContents :: MonadIO m => String -> RevisionId -> Html -> m () +cacheContents file revid contents = do + c <- queryAppState cache + let newpage = CachedPage { cpContents = contents + , cpRevisionId = revid } + let newcache = M.insert file newpage c + updateAppState $ \s -> s { cache = newcache } mkUser :: String -- username -> String -- email @@ -157,15 +198,9 @@ hashPassword :: String -> String -> String hashPassword salt pass = showDigest $ sha512 $ L.fromString $ salt ++ pass -addUser :: MonadState AppState m => String -> User -> m () -addUser name = modUsers . M.insert name - -delUser :: MonadState AppState m => String -> m () -delUser = modUsers . M.delete - -authUser :: MonadReader AppState m => String -> String -> m Bool +authUser :: MonadIO m => String -> String -> m Bool authUser name pass = do - users' <- askUsers + users' <- queryAppState users case M.lookup name users' of Just u -> do let salt = pSalt $ uPassword u @@ -173,45 +208,56 @@ return $ hashed == hashPassword salt pass Nothing -> return False -listUsers :: MonadReader AppState m => m [String] -listUsers = liftM M.keys askUsers +isUser :: MonadIO m => String -> m Bool +isUser name = liftM (M.member name) $ queryAppState users -numUsers :: MonadReader AppState m => m Int -numUsers = liftM length listUsers +addUser :: MonadIO m => String -> User -> m () +addUser uname user = updateAppState (\s -> s { users = M.insert uname user (users s) }) >> + liftIO writeUserFile -isSession :: MonadReader AppState m => SessionKey -> m Bool -isSession key = liftM (M.member key . unsession) askSessions +delUser :: MonadIO m => String -> m () +delUser uname = updateAppState (\s -> s { users = M.delete uname (users s) }) >> + liftIO writeUserFile -setSession :: (MonadState AppState m) => SessionKey -> SessionData -> m () -setSession key u = do - modSessions $ Sessions . M.insert key u . unsession - return () +writeUserFile :: IO () +writeUserFile = do + conf <- getConfig + usrs <- queryAppState users + liftIO $ writeFile (userFile conf) $ "[" ++ intercalate "\n," (map show $ M.toList usrs) ++ "\n]" -newSession :: (MonadState AppState (Ev (t GHC.Conc.STM)), MonadTrans t, Monad (t GHC.Conc.STM)) => - SessionData -> Ev (t GHC.Conc.STM) SessionKey +getUser :: MonadIO m => String -> m (Maybe User) +getUser uname = liftM (M.lookup uname) $ queryAppState users + +isSession :: MonadIO m => SessionKey -> m Bool +isSession key = liftM (M.member key . unsession) $ queryAppState sessions + +setSession :: MonadIO m => SessionKey -> SessionData -> m () +setSession key u = updateAppState $ \s -> s { sessions = Sessions . M.insert key u . unsession $ sessions s } + +newSession :: MonadIO m => SessionData -> m SessionKey newSession u = do - key <- getRandom + key <- liftIO $ randomRIO (0, 1000000000) setSession key u return key -delSession :: (MonadState AppState m) => SessionKey -> m () -delSession key = do - modSessions $ Sessions . M.delete key . unsession - return () - -getSession::SessionKey -> Query AppState (Maybe SessionData) -getSession key = liftM (M.lookup key . unsession) askSessions +delSession :: MonadIO m => SessionKey -> m () +delSession key = updateAppState $ \s -> s { sessions = Sessions . M.delete key . unsession $ sessions s } -getConfig :: Query AppState Config -getConfig = return . config =<< ask +getSession :: MonadIO m => SessionKey -> m (Maybe SessionData) +getSession key = queryAppState $ M.lookup key . unsession . sessions -setConfig :: MonadState AppState m => Config -> m () -setConfig conf = modify $ \s -> s {config = conf} +getConfig :: MonadIO m => m Config +getConfig = queryAppState config -numSessions:: Proxy AppState -> Query AppState Int -numSessions = proxyQuery $ liftM (M.size . unsession) askSessions +getFileStore :: MonadIO m => m FileStore +getFileStore = queryAppState filestore -$(mkMethods ''AppState ['askUsers, 'setUsers, 'addUser, 'delUser, 'authUser, 'isUser, 'listUsers, 'numUsers, - 'isSession, 'setSession, 'getSession, 'newSession, 'delSession, 'numSessions, - 'setConfig, 'getConfig]) +getMimeTypeForExtension :: MonadIO m => String -> m String +getMimeTypeForExtension ext = do + mimes <- queryAppState mimeMap + return $ case M.lookup (dropWhile (=='.') $ map toLower ext) mimes of + Nothing -> "application/octet-stream" + Just t -> t +getDefaultPageType :: MonadIO m => m PageType +getDefaultPageType = liftM defaultPageType (queryAppState config) diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -2,17 +2,17 @@ ===== Gitit is a wiki program written in Haskell. It uses [HAppS][] for the -web server and session state, [git][] for storage, history, search, -diffs, and merging, and [pandoc][] for markup processing. Pages and -uploaded files are stored in a git repository and may be modified either -by using git's command-line tools or through the wiki's web interface. -Pandoc's extended version of markdown is used as a markup language. -Pages can be exported in a number of different formats, including LaTeX, -RTF, OpenOffice ODT, and MediaWiki markup. Gitit can be configured to -display TeX math (using [jsMath][]) and highlighted source code (using -[highlighting-kate][]). +web server and [pandoc][] for markup processing. Pages and uploaded +files are stored in a [git][] or [darcs][] repository and may be modified either +by using the VCS's command-line tools or through the wiki's web interface. +By default, pandoc's extended version of markdown is used as a markup language, +but reStructuredText can also be used. Pages can be exported in a +number of different formats, including LaTeX, RTF, OpenOffice ODT, and +MediaWiki markup. Gitit can be configured to display TeX math (using +[jsMath][]) and highlighted source code (using [highlighting-kate][]). [git]: http://git.or.cz +[darcs]: http://darcs.net [pandoc]: http://johnmacfarlane.net/pandoc [HAppS]: http://happs.org [jsMath]: http://www.math.union.edu/~dpvc/jsMath/ @@ -93,7 +93,8 @@ option `-f [filename]`. A configuration file takes the following form: Config { - repositoryPath = "wikidata", + repository = Git "wikidata", + defaultPageType = Markdown, userFile = "gitit-users", templateFile = "template.html", staticDir = "static", @@ -107,13 +108,22 @@ accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]), useRecaptcha = False, recaptchaPublicKey = "", - recaptchaPrivateKey = "" + recaptchaPrivateKey = "", + mimeTypesFile = "/etc/mime.types" } -- `repositoryPath` is the (relative) path of the git repository in which - the wiki's pages will be stored. If it does not exist, gitit will create - it on startup. +- `repository` specifies the type and (relative) path of the repository + in which the wiki's pages will be stored. If it does not exist, gitit + will create it on startup. Supported repository types are `Git` and + `Darcs`. +- `defaultPageType` is the type of markup used to interpret pages in + the wiki. Two values are currently supported: `Markdown` and `RST`. + If `Markdown` is selected, [pandoc]'s syntax extensions (for footnotes, + delimited code blocks, etc.) will be enabled. Note that pandoc's + reStructuredText parser is not complete, so some pages may + not be rendered correctly if `RST` is selected. + - `userFile` is a file containing user login information (with hashed passwords). If it does not exist, gitit will start with an empty list of users. Gitit will write a new `userFile` on shutdown. @@ -160,6 +170,11 @@ . The values of these fields are ignored if `useRecaptcha` is set to `False`. +- `mimeTypesFile` is the path of a file containing mime type associations. + Each line of the file should contain a mime type, followed by some space, + followed by a space-separated list of file extensions that map to that mime + type. If the file is not found, some simple defaults will be used. + [reCAPTCHA]: http://recaptcha.net Configuring gitit @@ -175,6 +190,12 @@ of `static`, `css`, `img`, and `js`, which include the icons, stylesheets, and javascripts it uses. +Note: if you set `staticDir` to be a subdirectory of `repositoryPath`, +and then add the files in the static directory to your repository, you +can ensure that others who clone your wiki repository get these files +as well. It will not be possible to modify these files using the web +interface, but they will be modifiable via git. + Changing the theme ------------------ @@ -244,15 +265,9 @@ For instructions on editing pages and creating links, see the "Help" page. -Upgrading and `_local` -====================== - -HAppS uses the `_local` subdirectory to make state persistent. -Gitit does not rely on this persistence; the configuration and user database -are read from files on startup. So, it is okay to delete the `_local` -subdirectory. You may need to do this after you have upgraded to a new -version of gitit, with a different `AppState` data structure, because the -new gitit will not be able to read the old gitit's state. +Gitit interprets links with empty URLs as wikilinks. Thus, in markdown pages, +`[Front Page]()` creates an internal wikilink to the page `Front Page`. +In reStructuredText pages, `` `Front Page <>`_ `` has the same effect. Character encodings =================== @@ -270,10 +285,10 @@ Acknowledgements ================ -The visual layout is shamelessly borrowed from Wikipedia. +Gwern Brandwen helped to optimize Gitit. Simon Michael contributed the patch for +RST support. -The code in `Gitit/State.hs` is based on http://hpaste.org/5957 by mightybyte, -as revised by dbpatterson. +The visual layout is shamelessly borrowed from Wikipedia. The stylesheets are influenced by Wikipedia's stylesheets and by the bluetrip CSS framework (see BLUETRIP-LICENSE). Some of the icons in diff --git a/css/print.css b/css/print.css --- a/css/print.css +++ b/css/print.css @@ -19,6 +19,8 @@ h3{font-size:15pt;} h4,h5,h6{font-size:12pt;} +h2.revision { font-size: 10pt; font-weight: normal; font-style: italic; text-align: right; } + pre, code { font: 10pt Courier, monospace; } blockquote { margin: 1.3em; padding: 1em; font-size: 10pt; } hr { background-color: #ccc; } diff --git a/css/screen.css b/css/screen.css --- a/css/screen.css +++ b/css/screen.css @@ -1,9 +1,7 @@ -/* ----------------------------------------------------------------------- - gitit screen css - borrows heavily from Mike Crittenden's BlueTripCSS framework (GPL) - and from Wikipedia's CSS. ------------------------------------------------------------------------ */ +@import url("/css/hk-pyg.css"); +/* gitit screen css - borrows heavily from Mike Crittenden's BlueTripCSS framework (GPL) and from Wikipedia's CSS. */ + /* MEYER RESET */ html, body, div, span, object, iframe, h1, h2, h3, h4, h5, h6, p, blockquote, pre, a, abbr, acronym, address, code, del, dfn, em, img, q, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, caption, tbody, tfoot, thead, tr, th, td {margin:0;padding:0;border:0;font-weight:inherit;font-style:inherit;font-size:100%;font-family:inherit;vertical-align:baseline;} body {line-height:1.5;} @@ -50,23 +48,11 @@ body { font-size: 1em; line-height: 1.6em; } -hr { - height: 1px; - color: #aaa; - background-color: #aaa; - border: 0; - margin: .2em 0 .2em 0; +hr { height: 1px; color: #aaa; background-color: #aaa; border: 0; margin: .2em 0 .2em 0; } -h1, h2, h3, h4, h5, h6 { - color: black; - background: none; - font-weight: normal; - margin: 0; - padding-top: .5em; - padding-bottom: .17em; - border-bottom: 1px solid #aaa; -} +h1, h2, h3, h4, h5, h6 { color: black; background: none; font-weight: normal; margin: 0; + padding-top: .5em; padding-bottom: .17em; border-bottom: 1px solid #aaa; } h1.pageTitle { font-size: 220%; margin: 0.2em 0 .5em; } h1 { font-size: 150%; margin: 1.07em 0 .535em; } @@ -76,35 +62,12 @@ h5 { font-size: 88%; margin: 1.6em 0 .8em; } h6 { font-size: 80%; margin: 1.6em 0 .8em; } -ul { - line-height: 1.5em; - list-style-type: square; - margin: .3em 0 0 1.5em; - padding: 0; - list-style-image: url(bullet.gif); -} -ol { - line-height: 1.5em; - margin: .3em 0 0 3.2em; - padding: 0; - list-style-image: none; -} -li { - margin-bottom: .1em; -} -dt { - font-weight: bold; - margin-bottom: .1em; -} -dl { - margin-top: .2em; - margin-bottom: .5em; -} -dd { - line-height: 1.5em; - margin-left: 2em; - margin-bottom: .1em; -} +ul { line-height: 1.5em; list-style-type: square; margin: .3em 0 0 1.5em; padding: 0; } +ol { line-height: 1.5em; margin: .3em 0 0 3.2em; padding: 0; } +li { margin-bottom: .1em; } +dt { font-weight: bold; margin-bottom: .1em; } +dl { margin-top: .2em; margin-bottom: .5em; } +dd { line-height: 1.5em; margin-left: 2em; margin-bottom: .1em; } /* TABLES */ @@ -162,16 +125,8 @@ input.search_term { width: 95% } /* Standard Buttons */ -button:hover, a.button:hover{ - background-color:#dff4ff; - border:1px solid #c2e1ef; - color:#336699; -} -a.button:active, button:active{ - background-color:#6299c5; - border:1px solid #6299c5; - color:#fff; -} +button:hover, a.button:hover { background-color:#dff4ff; border:1px solid #c2e1ef; color:#336699; } +a.button:active, button:active { background-color:#6299c5; border:1px solid #6299c5; color:#fff; } /* Link icons */ @@ -212,176 +167,48 @@ color: black; text-decoration: none; } -body { - font: x-small sans-serif; - background: #f9f9f9; - color: black; - margin: 0; - padding: 0; -} -#container { - font-size: 120%; - margin: 0 ; - padding: 0; -} - -#userbox { text-align: right; font-weight: bold; margin: 1em 1em 0 0; } +body { font: x-small sans-serif; background: #f9f9f9; color: black; margin: 0; padding: 0; } +#container { font-size: 120%; margin: 0 ; padding: 0; } +#userbox { text-align: right; font-weight: bold; margin: 1em; } #logo { min-height: 50px; } #sidebar { width: 12em; float: left; margin-right: 10px; } -#sidebar fieldset { - background-color: white; - margin-bottom: 1em; - padding: 0; -} -#sidebar fieldset, #sidebar fieldset legend { - font-weight: normal; - font-size: 95%; -} -#sidebar ul { - padding: 0; - margin: 0; - margin-left: 1.6em; - line-height: 1.5em; -} +#sidebar fieldset { background-color: white; margin-bottom: 1em; padding: 0; } +#sidebar fieldset, #sidebar fieldset legend { font-weight: normal; font-size: 95%; } +#sidebar ul { padding: 0; margin: 0; margin-left: 1.6em; line-height: 1.5em; } #sidebar ul li { color: #888; } -#maincol { position: absolute; margin-left: 13em; margin-top: 1em; padding-top: 0; margin-right: 0; } +#maincol { position: absolute; margin-left: 13em; margin-top: 1em; padding-top: 0; margin-right: 0; max-width: 60em; } #content { border: 1px solid #ccc; background-color: #fff; padding: 1em; font-size: 110%; line-height: 150%; } -div#toc { - float: right; - background-color: #f9f9f9; - border: 10px solid white; - margin: 0.8em; - margin-right: 0; - padding: 0.4em; -} -#toc ul { - margin: 0; - padding-left: 1em; - list-style: none; -} -#toc > ul { - margin-right: 1em; -} +div#toc { float: right; background-color: #f9f9f9; border: 10px solid white; margin: 0.8em; margin-right: 0; padding: 0.4em; } +#toc ul { margin: 0; padding-left: 1em; list-style: none; } +#toc > ul { margin-right: 1em; } /* .req is used to hide a honeypot in a form */ -.req { - display: none; -} -ul.messages > li { - color: red; - list-style: square; - font-weight: bold; -} -ul.tabs { - padding: 0; - margin: 0; -} -ul.tabs li { - display: inline; - border: 1px solid #ccc; - border-bottom: none; - border-collapse: collapse; - padding: 0 0.6em 0 0.6em; - margin: 0 0 0 1.2em; - overflow: visible; - background: white; - line-height: 1.2em; -} -ul.tabs li.selected { - border-bottom: 3px solid white; -} -ul.tabs li a { - text-decoration: none; - font-size: 95%; - font-weight: bold; - margin: 0; - z-index: 0; - color: #36c; -} - -.folding ul { - list-style: none; - margin: 0; - padding: 0; -} -.folding li { - list-style: none; - background-position: 0 1px; - background-repeat: no-repeat; - padding-left: 20px; -} -.folding li.page { - background-image: url(/img/icons/page.png); -} -.folding li.folder { - background-image: url(/img/icons/folder.png); -} - -.folding a { - color: #000000; - cursor: pointer; - text-decoration: none; -} -.folding a:hover { - text-decoration: underline; -} -#sidebar input, #sidebar select { - font-size: 95%; - padding: 0.1em; -} -#exportbox select { - width: 8em; - border: 1px solid #ccc; - padding: 0; -} -#exportbox { - margin: 0.3em 0 0.5em 0.4em; - padding: 0; -} -#sidebar input[type='submit'] { - border: none; - background-color: #ccc; - color: white; -} -#searchform { - padding: 0; - margin: 0.3em 0 0.5em 0.4em; -} -#searchform input[type='text'] { - width: 7.5em; - border: 1px solid #ccc; -} +.req { display: none; } +ul.messages > li { color: red; list-style: square; font-weight: bold; } +ul.tabs { padding: 0; margin: 0; } +ul.tabs li { display: inline; border: 1px solid #ccc; border-bottom: none; border-collapse: collapse; padding: 0 0.6em 0 0.6em; + margin: 0 0 0 1.2em; overflow: visible; background: white; line-height: 1.2em; } +ul.tabs li.selected { border-bottom: 3px solid white; } +ul.tabs li a { text-decoration: none; font-size: 95%; font-weight: bold; margin: 0; z-index: 0; color: #36c; } +.folding ul { list-style: none; margin: 0; padding: 0; } +.folding li { list-style: none; background-position: 0 1px; background-repeat: no-repeat; padding-left: 20px; } +.folding li.page { background-image: url(/img/icons/page.png); } +.folding li.folder { background-image: url(/img/icons/folder.png); } +.folding a { color: #000000; cursor: pointer; text-decoration: none; } +.folding a:hover { text-decoration: underline; } +#sidebar input, #sidebar select { font-size: 95%; padding: 0.1em; } +#exportbox select { width: 8em; border: 1px solid #ccc; padding: 0; } +#exportbox { margin: 0.3em 0 0.5em 0.4em; padding: 0; } +#sidebar input[type='submit'] { border: none; background-color: #ccc; color: white; } +#searchform { padding: 0; margin: 0.3em 0 0.5em 0.4em; } +#searchform input[type='text'] { width: 7.5em; border: 1px solid #ccc; } +#goform { padding: 0; margin: 0.3em 0 0.5em 0.4em; } +#goform input[type='text'] { width: 7.5em; border: 1px solid #ccc; } .search_result { margin-bottom: 15px; } -.search_result .match { - line-height: 1em; - margin-bottom: 15px; -} -pre.matches { - font-size: .85em; - margin: 0; - padding: 0; -} -#editform textarea { - height: 25em; - width: 98%; -} -#editform #logMsg { - width: 98%; - margin-right: 1em; - margin-bottom: 0.3em; -} +.search_result .match { line-height: 1em; margin-bottom: 15px; } +pre.matches { font-size: .85em; margin: 0; padding: 0; } +#editform textarea { height: 25em; width: 98%; } +#editform #logMsg { width: 98%; margin-right: 1em; margin-bottom: 0.3em; } .added { background-color: yellow; } .deleted { text-decoration: line-through; color: gray; } -h2.revision { - font-size: 100%; - color: #888; - font-style: italic; - border: none; - margin: 0 0 0.5em 0; - padding: 0; -} -#footer { - padding: 1em; - color: #888; - text-align: center; - font-size: 95%; -} +h2.revision { font-size: 100%; color: #888; font-style: italic; border: none; margin: 0 0 0.5em 0; padding: 0; } +#footer { padding: 1em; color: #888; text-align: center; font-size: 95%; } diff --git a/data/FrontPage.page b/data/FrontPage.page --- a/data/FrontPage.page +++ b/data/FrontPage.page @@ -1,11 +1,14 @@ # Welcome to Gitit! -Gitit is a [Wiki] written in [Haskell]. [HAppS] is used for the web -server and session state. Pages and uploaded files are stored in a [git] -repository and may be modified either by using git's command-line tools -or through the wiki's web interface. [Pandoc]'s extended version of -[markdown] is used as a markup language. Gitit can be configured to -display TeX math and highlighted source code. +Gitit is a wiki program written in Haskell. It uses [HAppS][] for the +web server and [pandoc][] for markup processing. Pages and uploaded +files are stored in a [git][] or [darcs][] repository and may be modified either +by using the VCS's command-line tools or through the wiki's web interface. +By default, pandoc's extended version of markdown is used as a markup language, +but reStructuredText can also be used. Pages can be exported in a +number of different formats, including LaTeX, RTF, OpenOffice ODT, and +MediaWiki markup. Gitit can be configured to display TeX math (using +[jsMath][]) and highlighted source code (using [highlighting-kate][]). You can edit this page by double-clicking on it, or by clicking on the "edit" tab at the top of the screen. @@ -23,10 +26,12 @@ Help is always available through the "Help" link in the sidebar. -[Wiki]: http://en.wikipedia.org/wiki/Wiki -[git]: http://git.or.cz/ +[git]: http://git.or.cz +[darcs]: http://darcs.net +[pandoc]: http://johnmacfarlane.net/pandoc [HAppS]: http://happs.org +[jsMath]: http://www.math.union.edu/~dpvc/jsMath/ +[highlighting-kate]: http://johnmacfarlane.net/highlighting-kate/ [Haskell]: http://www.haskell.org/ -[pandoc]: http://johnmacfarlane.net/pandoc/ [markdown]: http://daringfireball.net/projects/markdown/ diff --git a/data/Help.page b/data/Help.page --- a/data/Help.page +++ b/data/Help.page @@ -7,6 +7,7 @@ folders if directories are used). Alternatively, you can search using the search box. Note that the search is set to look for whole words, so if you are looking for "gremlins", type that and not "gremlin". +The "go" box will take you directly to the page you type. # Markdown diff --git a/data/SampleConfig.hs b/data/SampleConfig.hs --- a/data/SampleConfig.hs +++ b/data/SampleConfig.hs @@ -1,5 +1,6 @@ Config { -repositoryPath = "wikidata", +repository = Git "wikidata", +defaultPageType = Markdown, userFile = "gitit-users", templateFile = "template.html", staticDir = "static", @@ -13,6 +14,7 @@ accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]), useRecaptcha = False, recaptchaPublicKey = "", -recaptchaPrivateKey = "" +recaptchaPrivateKey = "", +mimeTypesFile = "/etc/mime.types" } diff --git a/data/template.html b/data/template.html --- a/data/template.html +++ b/data/template.html @@ -8,11 +8,9 @@ $else$ - $endif$ - $javascripts$
@@ -49,14 +47,14 @@
$endif$ -
- $if(user)$ - Logout $user$ - $else$ - Login • Get an account - $endif$ -
+
+ $if(user)$ + Logout $user$ + $else$ + Login • Get an account + $endif$ +
$tabs$
$if(nothead)$ @@ -71,5 +69,6 @@
+ $javascripts$ diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,11 +1,11 @@ name: gitit -version: 0.4.1.3 +version: 0.5 Cabal-version: >= 1.2 build-type: Simple -synopsis: Wiki using HAppS, git, and pandoc. +synopsis: Wiki using HAppS, git or darcs, and pandoc. description: Gitit is a wiki program. Pages and uploaded files - are stored in a git repository and may be modified - either by using git's command-line tools or through + are stored in a git or darcs repository and may be modified + either by using the VCS's command-line tools or through the wiki's web interface. Pandoc's extended version of markdown is used as a markup language. Pages can be exported in a number of different formats, @@ -42,15 +42,14 @@ Executable gitit hs-source-dirs: . main-is: Gitit.hs - other-modules: Gitit.State, Gitit.Git, Gitit.HAppS, Gitit.Shell + other-modules: Gitit.State, Gitit.HAppS, Gitit.MimeTypes, 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, utf8-string, HAppS-Server >= 0.9.3 && < 0.9.4, - HAppS-State >= 0.9.3 && < 0.9.4, - HAppS-Data >= 0.9.3 && < 0.9.4, SHA > 1, HTTP, - HStringTemplate, random, network >= 2.1.0.0, recaptcha >= 0.1 + SHA > 1, HTTP, HStringTemplate, random, network >= 2.1.0.0, + recaptcha >= 0.1, filestore, datetime, zlib if impl(ghc >= 6.10) build-depends: base >= 4, syb ghc-options: -Wall -threaded diff --git a/img/icons/external.png b/img/icons/external.png Binary files a/img/icons/external.png and b/img/icons/external.png differ