diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -34,7 +34,9 @@ import Text.XHtml hiding ( (), dir, method, password ) 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, isJust) +import Data.Maybe (fromMaybe, fromJust, mapMaybe, isNothing) +import Data.ByteString.UTF8 (fromString) +import qualified Data.Map as M import Data.Ord (comparing) import qualified Data.Digest.SHA512 as SHA512 (hash) import Paths_gitit @@ -49,9 +51,10 @@ import Network.HTTP (urlEncodeVars, urlEncode) import System.Console.GetOpt import System.Exit +import Text.Highlighting.Kate gititVersion :: String -gititVersion = "0.1.1" +gititVersion = "0.2" main :: IO () main = do @@ -155,7 +158,7 @@ zipWithM copyFile stylesheetpaths (map (staticdir ) stylesheets) createDirectoryIfMissing True $ staticdir "javascripts" let javascripts = ["jquery.min.js", "jquery-ui-personalized-1.6rc2.min.js", - "folding.js", "dragdiff.js", "preview.js", "search.js"] + "folding.js", "dragdiff.js", "preview.js", "search.js", "uploadForm.js"] javascriptpaths <- mapM getDataFileName $ map ("javascripts" ) javascripts zipWithM copyFile javascriptpaths $ map ((staticdir "javascripts") ) javascripts hPutStrLn stderr $ "Created " ++ staticdir ++ " directory" @@ -171,26 +174,28 @@ wikiHandlers :: [Handler] -wikiHandlers = [ dir "_index" [ handle GET indexPage ] - , dir "_activity" [ handle GET showActivity ] - , dir "_preview" [ handle POST preview ] - , dir "_search" [ handle POST searchResults ] - , dir "_register" [ handle GET registerUserForm, - handle POST registerUser ] - , dir "_login" [ handle GET loginUserForm, - handle POST loginUser ] - , dir "_logout" [ handle GET logoutUser ] - , dir "_upload" [ handle GET uploadForm, - handle POST uploadFile ] +wikiHandlers = [ handlePath "_index" GET indexPage + , handlePath "_activity" GET showActivity + , handlePath "_preview" POST preview + , handlePath "_search" POST searchResults + , handlePath "_search" GET searchResults + , handlePath "_register" GET registerUserForm + , handlePath "_register" POST registerUser + , handlePath "_login" GET loginUserForm + , handlePath "_login" POST loginUser + , handlePath "_logout" GET logoutUser + , handlePath "_upload" GET (ifLoggedIn "" uploadForm) + , handlePath "_upload" POST (ifLoggedIn "" uploadFile) , handleCommand "showraw" GET showRawPage , handleCommand "history" GET showPageHistory - , handleCommand "edit" GET (unlessLocked editPage) + , handleCommand "edit" GET (unlessNoEdit $ ifLoggedIn "?edit" editPage) , handleCommand "diff" GET showDiff , handleCommand "cancel" POST showPage - , handleCommand "update" POST (unlessLocked updatePage) - , handleCommand "delete" GET (unlessLocked confirmDelete) - , handleCommand "delete" POST (unlessLocked deletePage) - , handle GET showPage + , handleCommand "update" POST (unlessNoEdit $ ifLoggedIn "?edit" updatePage) + , handleCommand "delete" GET (unlessNoDelete $ ifLoggedIn "?delete" confirmDelete) + , handleCommand "delete" POST (unlessNoDelete $ ifLoggedIn "?delete" deletePage) + , handlePage GET showPage + , handleSourceCode ] data Params = Params { pUsername :: String @@ -215,6 +220,8 @@ , pOverwrite :: Bool , pFilename :: String , pFileContents :: B.ByteString + , pUser :: String + , pConfirm :: Bool , pSessionKey :: Maybe SessionKey } deriving Show @@ -242,6 +249,7 @@ fn <- (lookInput "file" >>= return . fromMaybe "" . inputFilename) `mplus` return "" fc <- (lookInput "file" >>= return . inputValue) `mplus` return B.empty ac <- look "accessCode" `mplus` return "" + cn <- (look "confirm" >> return True) `mplus` return False sk <- (readCookieValue "sid" >>= return . Just) `mplus` return Nothing return $ Params { pUsername = un , pPassword = pw @@ -265,6 +273,8 @@ , pFilename = fn , pFileContents = fc , pAccessCode = ac + , pUser = "" -- this gets set by ifLoggedIn... + , pConfirm = cn , pSessionKey = sk } getLoggedInUser :: MonadIO m => Params -> m (Maybe String) @@ -287,28 +297,56 @@ [] -> Command Nothing (c:_) -> Command $ Just c -unlessLocked :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) -unlessLocked responder = +unlessNoEdit :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) +unlessNoEdit responder = \page params -> do cfg <- query GetConfig - if page `elem` lockedPages cfg + if page `elem` noEdit cfg then showPage page (params { pMessages = ("Page is locked." : pMessages params) }) else responder page params -handle :: Method -> (String -> Params -> Web Response) -> Handler -handle meth responder = uriRest $ \uri -> let uriPath = drop 1 $ takeWhile (/='?') uri - in if isPage uriPath - then withData $ \params -> - [ withRequest $ \req -> if rqMethod req == meth - then responder uriPath params - else noHandle ] - else anyRequest noHandle +unlessNoDelete :: (String -> Params -> Web Response) -> (String -> Params -> Web Response) +unlessNoDelete responder = + \page params -> do cfg <- query GetConfig + if page `elem` noDelete cfg + then showPage page (params { pMessages = ("Page cannot be deleted." : pMessages params) }) + else responder page params +ifLoggedIn :: String -> (String -> Params -> Web Response) -> (String -> Params -> Web Response) +ifLoggedIn fallback responder = + \page params -> do user <- getLoggedInUser params + case user of + Nothing -> seeOther ("/_login?" ++ urlEncodeVars [("destination", page ++ fallback)]) $ + toResponse $ p << "You must be logged in to perform this action." + Just u -> responder page (params { pUser = u }) + +handle :: (String -> Bool) -> Method -> (String -> Params -> Web Response) -> Handler +handle uritest meth responder = + uriRest $ \uri -> let uriPath = drop 1 $ takeWhile (/='?') uri + in if uritest uriPath + then withData $ \params -> + [ withRequest $ \req -> if rqMethod req == meth + then responder uriPath params + else noHandle ] + else anyRequest noHandle + +handlePage :: Method -> (String -> Params -> Web Response) -> Handler +handlePage = handle isPage + +handlePath :: String -> Method -> (String -> Params -> Web Response) -> Handler +handlePath path' = handle (== path') + handleCommand :: String -> Method -> (String -> Params -> Web Response) -> Handler handleCommand command meth responder = withData $ \com -> case com of - Command (Just c) | c == command -> [ handle meth responder ] + Command (Just c) | c == command -> [ handlePage meth responder ] _ -> [] +handleSourceCode :: Handler +handleSourceCode = withData $ \com -> + case com of + Command (Just "showraw") -> [ handle isSourceCode GET showFileAsText ] + _ -> [ handle isSourceCode GET showHighlightedSource ] + orIfNull :: String -> String -> String orIfNull str backup = if null str then backup else str @@ -316,6 +354,9 @@ isPage ('_':_) = False isPage s = '.' `notElem` s +isSourceCode :: String -> Bool +isSourceCode = not . null . languagesByExtension . takeExtension + urlForPage :: String -> String urlForPage page = "/" ++ urlEncode page @@ -330,12 +371,22 @@ 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 } + showRawPage :: String -> Params -> Web Response -showRawPage page params = do +showRawPage page = showFileAsText (pathForPage page) + +showFileAsText :: String -> Params -> Web Response +showFileAsText file params = do let revision = pRevision params - rawContents <- gitCatFile revision (pathForPage page) + rawContents <- gitCatFile revision file case rawContents of - Just c -> ok $ toResponse c + Just c -> ok $ setContentType "text/plain; charset=utf-8" $ toResponse c _ -> noHandle showPage :: String -> Params -> Web Response @@ -361,78 +412,86 @@ uploadForm :: String -> Params -> Web Response uploadForm _ params = do + let page = "_upload" let origPath = pFilename params let wikiname = pWikiname params `orIfNull` takeFileName origPath let logMsg = pLogMsg params let upForm = form ! [X.method "post", enctype "multipart/form-data"] << - [ p << [label << "File to upload:", br, afile "file" ! [value origPath]] - , p << [label << "Name on wiki, including extension:", br, textfield "wikiname" ! [value wikiname], + [ p << [label << "File to upload:", br, afile "file" ! [value origPath] ] + , p << [label << "Name on wiki, including extension", + noscript << " (leave blank to use the same filename)", stringToHtml ":", br, + textfield "wikiname" ! [value wikiname], primHtmlChar "nbsp", checkbox "overwrite" "yes", label << "Overwrite existing file"] , p << [label << "Description of content or changes:", br, textfield "logMsg" ! [size "60", value logMsg], submit "upload" "Upload"] ] - user <- getLoggedInUser params - if isJust user - then formattedPage [HidePageControls] [] "File upload" params upForm - else seeOther ("/_login?" ++ urlEncodeVars [("destination", "_upload")]) $ toResponse $ p << "You must be logged in to upload a file." + formattedPage [HidePageControls] ["uploadForm.js"] page params upForm uploadFile :: String -> Params -> Web Response uploadFile _ params = do + let page = "_upload" let origPath = pFilename params let fileContents = pFileContents params let wikiname = pWikiname params `orIfNull` takeFileName origPath let logMsg = pLogMsg params - user <- getLoggedInUser params - if isJust user + cfg <- query GetConfig + let author = pUser params + when (null author) $ fail "User must be logged in to upload a file." + let email = "" + let overwrite = pOverwrite params + exists <- liftIO $ doesFileExist (repositoryPath cfg wikiname) + -- these are the dangerous extensions in HAppS-Server.Server.HTTP.FileServe.mimeMap. + -- this list should be updated if mimeMap changes: + let imageExtensions = [".png", ".jpg", ".gif"] + let errors = validate [ (null logMsg, "Description cannot be empty.") + , (null origPath, "File not found.") + , (not overwrite && exists, "A file named '" ++ wikiname ++ + "' already exists in the repository: choose a new name " ++ + "or check the box to overwrite the existing file existing file.") + , (B.length fileContents > fromIntegral (maxUploadSize cfg), + "File exceeds maximum upload size.") + , (isPage wikiname, + "Uploaded file name must have an appropriate extension.") + ] + if null errors then do - cfg <- query GetConfig - let author = fromJust user - let email = "" - let overwrite = pOverwrite params - exists <- liftIO $ doesFileExist (repositoryPath cfg wikiname) - let errors = validate [ (null logMsg, "Description cannot be empty.") - , (null origPath, "File not found.") - , (not overwrite && exists, "A file named '" ++ wikiname ++ - "' already exists in the repository: choose a new name " ++ - "or check the box to overwrite the existing file existing file.") - , (B.length fileContents > fromIntegral (maxUploadSize cfg), - "File exceeds maximum upload size.") - , (isPage wikiname, - "Uploaded file name must have an appropriate extension.") - ] - if null errors - then do - if B.length fileContents > fromIntegral (maxUploadSize cfg) - then error "File exceeds maximum upload size" - else return () - let dir' = takeDirectory wikiname - liftIO $ createDirectoryIfMissing True ((repositoryPath cfg) dir') - liftIO $ B.writeFile ((repositoryPath cfg) wikiname) fileContents - gitCommit wikiname (author, email) logMsg - formattedPage [HidePageControls] [] "File upload" params $ - p << ("Uploaded " ++ show (B.length fileContents) ++ " bytes") - else uploadForm "File upload" (params { pMessages = errors }) - else seeOther ("/_login?" ++ urlEncodeVars [("destination", "_upload")]) $ toResponse $ p << "You must be logged in to upload a file." + if B.length fileContents > fromIntegral (maxUploadSize cfg) + then error "File exceeds maximum upload size" + else return () + let dir' = takeDirectory wikiname + liftIO $ createDirectoryIfMissing True ((repositoryPath cfg) dir') + liftIO $ B.writeFile ((repositoryPath cfg) wikiname) fileContents + gitCommit wikiname (author, email) logMsg + formattedPage [HidePageControls] [] page params $ + thediv << [ h2 << ("Uploaded " ++ show (B.length fileContents) ++ " bytes") + , if takeExtension wikiname `elem` imageExtensions + then p << "To add this image to a page, use:" +++ + pre << ("![alt text](" ++ wikiname ++ ")") + else p << "To link to this resource from a page, use:" +++ + pre << ("[link label](" ++ wikiname ++ ")") ] + else uploadForm page (params { pMessages = errors }) searchResults :: String -> Params -> Web Response searchResults _ params = do + let page = "_search" let patterns = pPatterns params let limit = pLimit params - if null patterns - then noHandle - else do - matchLines <- gitGrep patterns >>= return . map parseMatchLine . take limit . lines - 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 - then h3 << ["No matches found for '", unwords patterns, "':"] - else h3 << [(show $ length matches), " matches found for '", unwords patterns, "':"] - 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]", - pre ! [theclass "matches"] << unlines contents]) - (reverse $ sortBy (comparing (length . snd)) matches) - formattedPage [HidePageControls] ["search.js"] "Search Results" params htmlMatches + matchLines <- if null patterns + then return [] + else gitGrep patterns >>= return . map parseMatchLine . take limit . lines + 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 + then h3 << if null patterns + then ["Please enter a search term."] + else ["No matches found for '", unwords patterns, "':"] + else h3 << [(show $ length matches), " matches found for '", unwords patterns, "':"] + 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]", + pre ! [theclass "matches"] << unlines contents]) + (reverse $ sortBy (comparing (length . snd)) matches) + formattedPage [HidePageControls] ["search.js"] page params htmlMatches -- Auxiliary function for searchResults parseMatchLine :: String -> (String, String) @@ -469,12 +528,14 @@ showActivity :: String -> Params -> Web Response showActivity _ params = do + let page = "_activity" let since = pSince params `orIfNull` "1 month ago" let forUser = pForUser params hist <- gitLog since forUser [] let filesFor files = intersperse (primHtmlChar "nbsp") $ map (\file -> anchor ! [href $ urlForPage file ++ "?history"] << file) $ map (\file -> if ".page" `isSuffixOf` file then dropExtension file else file) files + 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 " (", thespan ! [theclass "author"] << anchor ! [href $ "/_activity?" ++ urlEncodeVars [("forUser", logAuthor entry)]] << @@ -482,7 +543,7 @@ thespan ! [theclass "subject"] << logSubject entry, stringToHtml " (", thespan ! [theclass "files"] << filesFor (logFiles entry), stringToHtml ")"]) hist - formattedPage [HidePageControls] [] ("Recent changes" ++ if null forUser then "" else (" by " ++ forUser)) params contents + formattedPage [HidePageControls] [] page params (heading +++ contents) showDiff :: String -> Params -> Web Response showDiff page params = do @@ -499,36 +560,31 @@ editPage :: String -> Params -> Web Response editPage page params = do - user <- getLoggedInUser params - if isJust user - then do - let revision = pRevision params - let messages = pMessages params - rawContents <- case pEditedText params of - Nothing -> gitCatFile revision (pathForPage page) - Just t -> return $ Just t - let (new, contents) = case rawContents of - Nothing -> (True, "# Title goes here\n\nContent goes here") - Just c -> (False, c) - let messages' = if new - then ("This page does not yet exist. You may create it by editing the text below." : messages) - else messages - sha1 <- case (pSHA1 params) of - "" -> gitGetSHA1 (pathForPage page) >>= return . fromMaybe "" - s -> return s - let logMsg = pLogMsg params - let sha1Box = textfield "sha1" ! [thestyle "display: none", value sha1] - let editForm = gui (urlForPage page) ! [identifier "editform"] << - [sha1Box, - textarea ! [cols "80", name "editedText", identifier "editedText"] << contents, - label << "Description of changes:", br, - textfield "logMsg" ! [size "76", value logMsg], - submit "update" "Save", primHtmlChar "nbsp", - submit "cancel" "Discard", br, - thediv ! [ identifier "previewpane" ] << noHtml ] - formattedPage [HidePageControls, HideNavbar] ["preview.js"] page (params {pMessages = messages'}) editForm - else do - seeOther ("/_login?" ++ urlEncodeVars [("destination", page ++ "?edit")]) $ toResponse $ p << "You must be logged in to edit a page." + let revision = pRevision params + let messages = pMessages params + rawContents <- case pEditedText params of + Nothing -> gitCatFile revision (pathForPage page) + Just t -> return $ Just t + let (new, contents) = case rawContents of + Nothing -> (True, "# Title goes here\n\nContent goes here") + Just c -> (False, c) + let messages' = if new + then ("This page does not yet exist. You may create it by editing the text below." : messages) + else messages + sha1 <- case (pSHA1 params) of + "" -> gitGetSHA1 (pathForPage page) >>= return . fromMaybe "" + s -> return s + let logMsg = pLogMsg params + let sha1Box = textfield "sha1" ! [thestyle "display: none", value sha1] + let editForm = gui (urlForPage page) ! [identifier "editform"] << + [sha1Box, + textarea ! [cols "80", name "editedText", identifier "editedText"] << contents, + label << "Description of changes:", br, + textfield "logMsg" ! [size "76", value logMsg], + submit "update" "Save", primHtmlChar "nbsp", + submit "cancel" "Discard", br, + thediv ! [ identifier "previewpane" ] << noHtml ] + formattedPage [HidePageControls, HideNavbar] ["preview.js"] page (params {pMessages = messages'}) editForm confirmDelete :: String -> Params -> Web Response confirmDelete page params = do @@ -538,32 +594,26 @@ , stringToHtml " " , submit "cancel" "No, keep it!" , br ] - user <- getLoggedInUser params - if isJust user - then formattedPage [HidePageControls] [] page params confirmForm - else seeOther ("/_login?" ++ urlEncodeVars [("destination", page ++ "?delete")]) $ toResponse $ p << "You must be logged in to delete a page." + formattedPage [HidePageControls] [] page params confirmForm deletePage :: String -> Params -> Web Response deletePage page params = do - user <- getLoggedInUser params - if isNothing user - then fail "User must be logged in to delete page." - else return () - let author = fromJust user - let email = "" - gitRemove (pathForPage page) (author, email) "Deleted from web." - seeOther "/" $ toResponse $ p << "Page deleted" + if pConfirm params + then do + let author = pUser params + when (null author) $ fail "User must be logged in to delete page." + let email = "" + gitRemove (pathForPage page) (author, email) "Deleted from web." + seeOther "/" $ toResponse $ p << "Page deleted" + else seeOther (urlForPage page) $ toResponse $ p << "Page not deleted" updatePage :: String -> Params -> Web Response updatePage page params = do - user <- getLoggedInUser params - if isNothing user - then fail "User must be logged in to update page." - else return () + let author = pUser params + when (null author) $ fail "User must be logged in to update page." let editedText = case pEditedText params of Nothing -> error "No body text in POST request" Just b -> b - let author = fromJust user let email = "" let logMsg = pLogMsg params let oldSHA1 = pSHA1 params @@ -575,12 +625,14 @@ 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 + 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 @@ -588,7 +640,6 @@ latest <- gitCatFile currentSHA1 (pathForPage page) >>= return . fromJust let pagePath = repositoryPath cfg pathForPage page let [textTmp, originalTmp, latestTmp] = map (pagePath ++) [".edited",".original",".latest"] - let editedText' = if null editedText || last editedText == '\n' then editedText else editedText ++ "\n" liftIO $ writeFile textTmp editedText' liftIO $ writeFile originalTmp original liftIO $ writeFile latestTmp latest @@ -604,10 +655,11 @@ indexPage :: String -> Params -> Web Response indexPage _ params = do + let page = "_index" let revision = pRevision params files <- gitLsTree revision >>= return . map (unwords . drop 3 . words) . lines let htmlIndex = fileListToHtml "/" $ map splitPath $ sort files - formattedPage [HidePageControls] ["folding.js"] "index" params htmlIndex + formattedPage [HidePageControls] ["folding.js"] page params htmlIndex -- | Map a list of nonempty lists onto a list of pairs of list heads and list of tails. -- e.g. [[1,2],[1],[2,1]] -> [(1,[[2],[]]), (2,[[1]])] @@ -714,7 +766,9 @@ let body' = body << thediv ! [identifier "container"] << [ thediv ! [identifier "banner"] << primHtml (wikiBanner cfg) , thediv ! [identifier "navbar", thestyle $ "visibility: " ++ sitenavVis] << [userbox, sitenav] - , thediv ! [identifier "pageTitle"] << [ anchor ! [href $ urlForPage page] << (h1 << page) ] + , case page of + '_':_ -> noHtml + _ -> thediv ! [identifier "pageTitle"] << [ anchor ! [href $ urlForPage page] << (h1 << page) ] , thediv ! [identifier "content"] << [htmlMessages, htmlContents] , thediv ! [identifier "pageinfo"] << [ thediv ! [theclass "pageControls", thestyle $ "visibility: " ++ sidebarVis] << buttons , thediv ! [theclass "details"] << revision ] @@ -735,7 +789,7 @@ , anchor ! [href ("/_register?" ++ urlEncodeVars [("destination", destination)])] << "click here to register." ]] loginUserForm :: String -> Params -> Web Response -loginUserForm _ params = formattedPage [HidePageControls] [] "Login" params $ loginForm params +loginUserForm _ params = formattedPage [HidePageControls] [] "_login" params $ loginForm params loginUser :: String -> Params -> Web Response loginUser _ params = do @@ -751,7 +805,7 @@ addCookie (3600) (mkCookie "sid" (show key)) seeOther ("/" ++ intercalate "%20" (words destination)) $ toResponse $ p << ("Welcome, " ++ uname) else - formattedPage [HidePageControls] [] "Login" (params { pMessages = ["Authentication failed."] }) (loginForm params) + loginUserForm "_login" (params { pMessages = "Authentication failed." : pMessages params }) logoutUser :: String -> Params -> Web Response logoutUser _ params = do @@ -781,11 +835,13 @@ registerUserForm :: String -> Params -> Web Response registerUserForm _ params = do + let page = "_register" regForm <- registerForm - formattedPage [HidePageControls] [] "Register" params regForm + formattedPage [HidePageControls] [] page params regForm registerUser :: String -> Params -> Web Response registerUser _ params = do + let page = "_register" regForm <- registerForm let isValidUsername u = length u >= 3 && all isAlphaNum u let isValidPassword pw = length pw >= 6 && not (all isAlpha pw) @@ -810,6 +866,16 @@ let passwordHash = SHA512.hash $ map c2w $ passwordSalt cfg ++ pword update $ AddUser uname (User { username = uname, password = passwordHash }) loginUser "Front Page" (params { pUsername = uname, pPassword = pword, pDestination = "Front Page" }) - else formattedPage [HidePageControls] [] "Register" (params { pMessages = errors }) regForm + else formattedPage [HidePageControls] [] page (params { pMessages = errors }) regForm +showHighlightedSource :: String -> Params -> Web Response +showHighlightedSource file params = do + let revision = pRevision params + catResult <- liftIO $ gitCatFile revision file + case catResult of + Just source -> let lang' = head $ languagesByExtension $ takeExtension file + in case highlightAs lang' (filter (/='\r') source) of + Left _ -> noHandle + Right res -> formattedPage [] [] file params $ formatAsXHtml [OptNumberLines] lang' res + Nothing -> noHandle diff --git a/Gitit/Git.hs b/Gitit/Git.hs --- a/Gitit/Git.hs +++ b/Gitit/Git.hs @@ -118,11 +118,17 @@ -> m String -- ^ String gitDiff file from to = do repo <- (query GetConfig) >>= return . repositoryPath - (status, errOut, output) <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) - "git" ["diff", from, to, file] + (status, _, output) <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) + "git" ["diff", from, to, file] if status == ExitSuccess then return output - else error $ "git diff returned error: " ++ errOut + else do + -- try it without the path, since the error might be "not in working tree" for a deleted file + (status', errOut', output') <- liftIO $ runShellCommand repo (Just [("GIT_DIFF_OPTS","-u100000")]) + "git" ["diff", from, to] + 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 () diff --git a/Gitit/State.hs b/Gitit/State.hs --- a/Gitit/State.hs +++ b/Gitit/State.hs @@ -47,7 +47,8 @@ portNumber :: Int, -- port number to serve content on passwordSalt :: String, -- text to serve as salt in encrypting passwords debugMode :: Bool, -- should debug info be printed to the console? - lockedPages :: [String], -- pages that cannot be edited through the web interface + noEdit :: [String], -- pages that cannot be edited through the web interface + noDelete :: [String], -- pages that cannot be deleted through the web interface accessQuestion :: Maybe (String, [String]) -- if Nothing, then anyone can register for an account. -- if Just (prompt, answers), then a user will be given the prompt -- and must give one of the answers in order to register. @@ -65,7 +66,8 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = False, - lockedPages = ["Help"], + noEdit = ["Help"], + noDelete = ["Help", "Front Page"], accessQuestion = Nothing } diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -95,7 +95,8 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = True, - lockedPages = ["Help"], + noEdit = ["Help"], + noDelete = ["Help", "Front Page"], accessQuestion = Just ("Enter the access code (to request a code, contact me@foo.bar.com):", ["abcd"]) } @@ -110,8 +111,9 @@ - The `passwordSalt` is used to encrypt passwords and should be changed for every new site. - `debugMode` causes diagnostic information to be printed to the console. -- `lockedPages` is a list of pages that cannot be edited from the web interface. +- `noEdit` is a list of pages that cannot be edited using the web interface. (They may still be edited via git, by those with access to the repository.) +- `noDelete` is a list of pages that cannot be deleted using the web interface. - The `accessQuestion` is either `Nothing` (in which case anyone will be allowed to register for an account) or `Just (question, [ans1, ans2, ...])` (in which case anyone who registers must first answer the `question` with diff --git a/data/SampleConfig.hs b/data/SampleConfig.hs --- a/data/SampleConfig.hs +++ b/data/SampleConfig.hs @@ -9,7 +9,8 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = True, -lockedPages = ["Help", "Front Page"], +noEdit = ["Help", "Front Page"], +noDelete = ["Help", "Front Page"], accessQuestion = Just ("Enter the access code (to request an access code, contact me@somewhere.org):", ["abcd"]) } diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -1,5 +1,5 @@ name: gitit -version: 0.1.1 +version: 0.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc. description: Gitit is a wiki program. HAppS is used for the web @@ -22,7 +22,7 @@ data-files: stylesheets/gitit.css, stylesheets/hk-pyg.css, stylesheets/folder.png, stylesheets/page.png, javascripts/dragdiff.js, javascripts/folding.js, - javascripts/jquery.min.js, + javascripts/jquery.min.js, javascripts/uploadForm.js, javascripts/jquery-ui-personalized-1.6rc2.min.js, javascripts/preview.js, javascripts/search.js, data/post-update, data/FrontPage.page, data/Help.page, @@ -35,7 +35,8 @@ build-depends: base, parsec < 3, pretty, xhtml, containers, pandoc >= 1.1, process, filepath, directory, mtl, cgi, network, old-time, highlighting-kate, bytestring, - utf8-string, HAppS-Server, HAppS-State, HAppS-Data, + utf8-string, HAppS-Server == 0.9.2.1, + HAppS-State == 0.9.2.1, HAppS-Data == 0.9.2.1, Crypto, HTTP ghc-options: -Wall -threaded diff --git a/javascripts/uploadForm.js b/javascripts/uploadForm.js new file mode 100644 --- /dev/null +++ b/javascripts/uploadForm.js @@ -0,0 +1,3 @@ +$(document).ready(function(){ + $("#file").change(function () { $("#wikiname").val($(this).val()); }); + });