gitit 0.1.1 → 0.2
raw patch · 7 files changed
+234/−153 lines, 7 filesdep ~HAppS-Datadep ~HAppS-Serverdep ~HAppS-State
Dependency ranges changed: HAppS-Data, HAppS-Server, HAppS-State
Files
- Gitit.hs +208/−142
- Gitit/Git.hs +9/−3
- Gitit/State.hs +4/−2
- README.markdown +4/−2
- data/SampleConfig.hs +2/−1
- gitit.cabal +4/−3
- javascripts/uploadForm.js +3/−0
Gitit.hs view
@@ -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
Gitit/Git.hs view
@@ -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 ()
Gitit/State.hs view
@@ -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 }
README.markdown view
@@ -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
data/SampleConfig.hs view
@@ -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"]) }
gitit.cabal view
@@ -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
+ javascripts/uploadForm.js view
@@ -0,0 +1,3 @@+$(document).ready(function(){+ $("#file").change(function () { $("#wikiname").val($(this).val()); });+ });