gitit 0.2.1 → 0.2.2
raw patch · 6 files changed
+275/−107 lines, 6 files
Files
- Gitit.hs +267/−106
- Gitit/State.hs +2/−0
- README.markdown +3/−0
- data/SampleConfig.hs +1/−0
- gitit.cabal +1/−1
- stylesheets/gitit.css +1/−0
Gitit.hs view
@@ -24,6 +24,8 @@ 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 System.Directory@@ -41,6 +43,7 @@ import qualified Data.Digest.SHA512 as SHA512 (hash) import Paths_gitit import Text.Pandoc+import Text.Pandoc.ODT (saveOpenDocumentAsODT) import Text.Pandoc.Definition (processPandoc) import Text.Pandoc.Shared (HTMLMathMethod(..)) import Data.ByteString.Internal (c2w)@@ -54,7 +57,7 @@ import Text.Highlighting.Kate gititVersion :: String-gititVersion = "0.2.1"+gititVersion = "0.2.2" main :: IO () main = do@@ -63,7 +66,7 @@ conf <- foldM handleFlag defaultConfig options gitPath <- findExecutable "git" when (isNothing gitPath) $ error "'git' program not found in system path."- initializeWiki (repositoryPath conf) (staticDir conf)+ initializeWiki conf control <- startSystemState entryPoint update $ SetConfig conf hPutStrLn stderr $ "Starting server on port " ++ show (portNumber conf)@@ -72,7 +75,7 @@ [ dir "stylesheets" [ fileServe [] $ (staticDir conf) </> "stylesheets" ] , dir "images" [ fileServe [] $ (staticDir conf) </> "images" ] , dir "javascripts" [ fileServe [] $ (staticDir conf) </> "javascripts" ]- ] ++ wikiHandlers ++ [ fileServe [] (repositoryPath conf) ]+ ] ++ wikiHandlers waitForTermination putStrLn "Shutting down..." killThread tid@@ -124,8 +127,11 @@ entryPoint = Proxy -- | Create repository and public directories, unless they already exist.-initializeWiki :: FilePath -> FilePath -> IO ()-initializeWiki repodir staticdir = do+initializeWiki :: Config -> IO ()+initializeWiki conf = do+ let repodir = repositoryPath conf+ let frontpage = frontPage conf <.> "page"+ let staticdir = staticDir conf repoExists <- doesDirectoryExist repodir unless repoExists $ do postupdatepath <- getDataFileName $ "data" </> "post-update"@@ -139,9 +145,9 @@ setCurrentDirectory repodir runCommand "git init" >>= waitForProcess -- add front page and help page- B.writeFile "Front Page.page" welcomecontents+ B.writeFile frontpage welcomecontents B.writeFile "Help.page" helpcontents- runCommand "git add 'Help.page' 'Front Page.page'; git commit -m 'Initial commit.'" >>= waitForProcess+ 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"@@ -186,16 +192,20 @@ , 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 (unlessNoEdit $ ifLoggedIn "?edit" editPage)- , handleCommand "diff" GET showDiff- , handleCommand "cancel" POST 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+ , withCommand "showraw" [ handlePage GET showRawPage ]+ , withCommand "history" [ handlePage GET showPageHistory,+ handle (not . isPage) GET showFileHistory ]+ , withCommand "edit" [ handlePage GET $ unlessNoEdit $ ifLoggedIn "?edit" editPage ]+ , withCommand "diff" [ handlePage GET showPageDiff,+ handle isSourceCode GET showFileDiff ]+ , withCommand "export" [ handlePage POST exportPage, handlePage GET exportPage ]+ , withCommand "cancel" [ handlePage POST showPage ]+ , withCommand "update" [ handlePage POST $ unlessNoEdit $ ifLoggedIn "?edit" updatePage ]+ , withCommand "delete" [ handlePage GET $ unlessNoDelete $ ifLoggedIn "?delete" confirmDelete,+ handlePage POST $ unlessNoDelete $ ifLoggedIn "?delete" deletePage ] , handleSourceCode+ , handleAny+ , handlePage GET showPage ] data Params = Params { pUsername :: String@@ -212,6 +222,7 @@ , pMessages :: [String] , pFrom :: String , pTo :: String+ , pFormat :: String , pSHA1 :: String , pLogMsg :: String , pEmail :: String@@ -241,6 +252,7 @@ fm <- look "from" `mplus` return "HEAD" to <- look "to" `mplus` return "HEAD" et <- (look "editedText" >>= return . Just . filter (/= '\r')) `mplus` return Nothing+ fo <- look "format" `mplus` return "" sh <- look "sha1" `mplus` return "" lm <- look "logMsg" `mplus` return "" em <- look "email" `mplus` return ""@@ -265,6 +277,7 @@ , pFrom = fm , pTo = to , pEditedText = et+ , pFormat = fo , pSHA1 = sh , pLogMsg = lm , pEmail = em@@ -288,7 +301,7 @@ data Command = Command (Maybe String) commandList :: [String]-commandList = ["edit", "showraw", "history", "diff", "cancel", "update", "delete"]+commandList = ["edit", "showraw", "history", "export", "diff", "cancel", "update", "delete"] instance FromData Command where fromData = do@@ -332,13 +345,16 @@ handlePage :: Method -> (String -> Params -> Web Response) -> Handler handlePage = handle isPage +handleText :: Method -> (String -> Params -> Web Response) -> Handler+handleText = handle (\x -> isPage x || isSourceCode x)+ handlePath :: String -> Method -> (String -> Params -> Web Response) -> Handler handlePath path' = handle (== path') -handleCommand :: String -> Method -> (String -> Params -> Web Response) -> Handler-handleCommand command meth responder =+withCommand :: String -> [Handler] -> Handler+withCommand command handlers = withData $ \com -> case com of- Command (Just c) | c == command -> [ handlePage meth responder ]+ Command (Just c) | c == command -> handlers _ -> [] handleSourceCode :: Handler@@ -347,6 +363,16 @@ Command (Just "showraw") -> [ handle isSourceCode GET showFileAsText ] _ -> [ handle isSourceCode GET showHighlightedSource ] +handleAny :: Handler+handleAny = + uriRest $ \uri -> let uriPath = drop 1 $ takeWhile (/='?') uri+ in do cfg <- query GetConfig+ let file = repositoryPath cfg </> uriPath+ exists <- liftIO $ doesFileExist file+ if exists+ then fileServe [uriPath] (repositoryPath cfg)+ else anyRequest noHandle+ orIfNull :: String -> String -> String orIfNull str backup = if null str then backup else str @@ -378,28 +404,39 @@ 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; " ++ urlEncodeVars [("filename", fname)] ] }+ in res { rsHeaders = M.insert (fromString "content-disposition") newContentType respHeaders } + showRawPage :: String -> Params -> Web Response-showRawPage page = showFileAsText (pathForPage page)+showRawPage page = showFileAsText $ pathForPage page showFileAsText :: String -> Params -> Web Response showFileAsText file params = do- let revision = pRevision params- rawContents <- gitCatFile revision file- case rawContents of- Just c -> ok $ setContentType "text/plain; charset=utf-8" $ toResponse c- _ -> noHandle+ mContents <- rawContents file params+ case mContents of+ Nothing -> error "Unable to retrieve page contents."+ Just c -> ok $ setContentType "text/plain; charset=utf-8" $ toResponse c showPage :: String -> Params -> Web Response-showPage "" params = showPage "Front Page" params >>= seeOther "/Front%20Page"+showPage "" params = do+ cfg <- query GetConfig+ showPage (frontPage cfg) params showPage page params = do let revision = pRevision params- rawContents <- gitCatFile revision (pathForPage page)- case rawContents of- Just c -> do- cont <- convertToHtml c+ 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+ strAttr "onDblClick" ("window.location = '" ++ urlForPage page ++ + "?edit&revision=" ++ revision +++ (if revision == "HEAD"+ then ""+ else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)]) ++ "';")] << cont formattedPage [] ["jsMath/easy/load.js"] page params cont' _ -> if revision == "HEAD" then editPage page params@@ -450,7 +487,7 @@ , (B.length fileContents > fromIntegral (maxUploadSize cfg), "File exceeds maximum upload size.") , (isPage wikiname,- "Uploaded file name must have an appropriate extension.")+ "This file extension is reserved for wiki pages.") ] if null errors then do@@ -501,30 +538,41 @@ in (file, contents) preview :: String -> Params -> Web Response-preview _ params = convertToHtml (pRaw params) >>= ok . toResponse+preview _ params = pandocToHtml (textToPandoc $ pRaw params) >>= ok . toResponse showPageHistory :: String -> Params -> Web Response-showPageHistory page params = do+showPageHistory page params = showHistory (pathForPage page) page params++showFileHistory :: String -> Params -> Web Response+showFileHistory file params = showHistory file file params++showHistory :: String -> String -> Params -> Web Response+showHistory file page params = do let since = pSince params `orIfNull` "1 year ago"- hist <- gitLog since "" [pathForPage page]- let versionToHtml entry pos = li ! [theclass "difflink", intAttr "order" pos, strAttr "revision" $ logRevision entry] <<- [thespan ! [theclass "date"] << logDate entry, 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,- noscript << ([stringToHtml " [compare with ",- anchor ! [href $ urlForPage page ++ "?diff&from=" ++ logRevision entry ++- "^&to=" ++ logRevision entry] << "previous"] ++- (if pos /= 1- then [primHtmlChar "nbsp", primHtmlChar "bull",- primHtmlChar "nbsp",- anchor ! [href $ urlForPage page ++ "?diff&from=" ++- logRevision entry ++ "&to=HEAD"] << "current" ]- else []) ++- [stringToHtml "]"])]- let contents = ulist ! [theclass "history"] << zipWith versionToHtml hist [(length hist), (length hist - 1)..1]- formattedPage [] ["dragdiff.js"] page params contents+ hist <- gitLog since "" [file]+ 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 " (",+ 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,+ noscript << ([stringToHtml " [compare with ",+ anchor ! [href $ urlForPage page ++ "?diff&from=" ++ logRevision entry +++ "^&to=" ++ logRevision entry] << "previous"] +++ (if pos /= 1+ then [primHtmlChar "nbsp", primHtmlChar "bull",+ primHtmlChar "nbsp",+ anchor ! [href $ urlForPage page ++ "?diff&from=" +++ logRevision entry ++ "&to=HEAD"] << "current" ]+ else []) +++ [stringToHtml "]"])]+ let contents = ulist ! [theclass "history"] << zipWith versionToHtml hist [(length hist), (length hist - 1)..1]+ formattedPage [] ["dragdiff.js"] page params contents showActivity :: String -> Params -> Web Response showActivity _ params = do@@ -538,18 +586,25 @@ 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)]] <<- (logAuthor entry), 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), stringToHtml ")"]) hist formattedPage [HidePageControls] [] page params (heading +++ contents) -showDiff :: String -> Params -> Web Response-showDiff page params = do+showPageDiff :: String -> Params -> Web Response+showPageDiff page params = showDiff (pathForPage page) page params++showFileDiff :: String -> Params -> Web Response+showFileDiff page params = showDiff page page params++showDiff :: String -> String -> Params -> Web Response+showDiff file page params = do let from = pFrom params let to = pTo params- rawDiff <- gitDiff (pathForPage page) from to+ rawDiff <- gitDiff file from to let diffLineToHtml l = case head l of '+' -> thespan ! [theclass "added"] << [tail l, "\n"] '-' -> thespan ! [theclass "deleted"] << [tail l, "\n"]@@ -562,10 +617,10 @@ editPage page params = 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+ raw <- case pEditedText params of+ Nothing -> gitCatFile revision (pathForPage page)+ Just t -> return $ Just t+ let (new, contents) = case raw of Nothing -> (True, "# Title goes here\n\nContent goes here") Just c -> (False, c) let messages' = if new@@ -695,17 +750,14 @@ refToUrl (_:_) = error "Encountered an inline other than Str or Space" refToUrl [] = "" --- | Converts markdown string to HTML.-convertToHtml :: MonadIO m => String -> m Html-convertToHtml text' = do+-- | Converts pandoc document to HTML.+pandocToHtml :: MonadIO m => Pandoc -> m Html+pandocToHtml pandocContents = do cfg <- query GetConfig- let pandocContents = readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) $- filter (/= '\r') $ decodeString $ text'- let htmlContents = writeHtml (defaultWriterOptions { writerStandalone = False- , writerHTMLMathMethod = JsMath (Just "/javascripts/jsMath/easy/load.js")- , writerTableOfContents = tableOfContents cfg- }) $ processPandoc convertWikiLinks pandocContents- return htmlContents+ return $ writeHtml (defaultWriterOptions { writerStandalone = False+ , writerHTMLMathMethod = JsMath (Just "/javascripts/jsMath/easy/load.js")+ , writerTableOfContents = tableOfContents cfg+ }) $ processPandoc convertWikiLinks pandocContents data PageOption = HidePageControls | HideNavbar deriving (Eq, Show) @@ -726,37 +778,36 @@ else concatHtml $ map (\x -> script ! [src ("/javascripts/" ++ x), thetype "text/javascript"] << noHtml) (["jquery.min.js", "jquery-ui-personalized-1.6rc2.min.js"] ++ scripts)- let title' = thetitle << (wikiTitle cfg ++ " - " ++ page)+ let title' = thetitle << (wikiTitle cfg ++ " - " ++ dropWhile (=='_') page) let head' = header << [title', stylesheetlinks, javascriptlinks] let sitenav = thediv ! [theclass "sitenav"] << gui ("/_search") ! [identifier "searchform"] <<- [ anchor ! [href "/Front%20Page", theclass "nav_link"] << "front"- , primHtmlChar "bull"- , anchor ! [href "/_index", theclass "nav_link"] << "index"- , primHtmlChar "bull"- , anchor ! [href "/_upload", theclass "nav_link"] << "upload"- , primHtmlChar "bull"- , anchor ! [href "/_activity", theclass "nav_link"] << "activity"- , primHtmlChar "bull"- , anchor ! [href "/Help", theclass "nav_link"] << "help"- , primHtmlChar "nbsp"- , textfield "patterns" ! [theclass "search_field search_term"]- , submit "search" "Search" ]- let buttons = [ anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&showraw", theclass "nav_link"] << "raw"- , primHtmlChar "bull"- , anchor ! [href $ urlForPage page ++ "?delete", theclass "nav_link"] << "delete"- , primHtmlChar "bull"- , anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&history", theclass "nav_link"] << "history"- , primHtmlChar "bull"- , anchor ! [href $ urlForPage page ++ "?edit&revision=" ++ revision ++- if revision == "HEAD" then "" else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)],- theclass "nav_link"] << if revision == "HEAD" then "edit" else "revert" ]+ (intersperse (primHtmlChar "bull")+ [ anchor ! [href "/", theclass "nav_link"] << "front"+ , anchor ! [href "/_index", theclass "nav_link"] << "index"+ , anchor ! [href "/_upload", theclass "nav_link"] << "upload"+ , anchor ! [href "/_activity", theclass "nav_link"] << "activity"+ , anchor ! [href "/Help", theclass "nav_link"] << "help" ] +++ [ primHtmlChar "nbsp"+ , textfield "patterns" ! [theclass "search_field search_term"]+ , submit "search" "Search" ])+ let rawButton = anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&showraw", theclass "nav_link"] << "raw"+ let delButton = anchor ! [href $ urlForPage page ++ "?delete", theclass "nav_link"] << "delete"+ let histButton = anchor ! [href $ urlForPage page ++ "?revision=" ++ revision ++ "&history", theclass "nav_link"] << "history"+ let editButton = anchor ! [href $ urlForPage page ++ "?edit&revision=" ++ revision +++ if revision == "HEAD" then "" else "&" ++ urlEncodeVars [("logMsg", "Revert to " ++ revision)],+ theclass "nav_link"] << if revision == "HEAD" then "edit" else "revert"+ let buttons = intersperse (primHtmlChar "bull") $ + (if isPage page then [rawButton] else []) ++ [delButton, histButton] +++ (if isPage page then [editButton] else []) let userbox = thediv ! [identifier "userbox"] << case user of- Just u -> anchor ! [href ("/_logout?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] << ("logout " ++ u)- Nothing -> (anchor ! [href ("/_login?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] << "login") +++- primHtmlChar "bull" +++- anchor ! [href ("/_register?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] << "register"+ Just u -> anchor ! [href ("/_logout?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] << + ("logout " ++ u)+ Nothing -> (anchor ! [href ("/_login?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] <<+ "login") +++ primHtmlChar "bull" ++++ anchor ! [href ("/_register?" ++ urlEncodeVars [("destination", page)]), theclass "nav_link"] <<+ "register" let sitenavVis = if HideNavbar `elem` opts then "hidden" else "visible" let sidebarVis = if HidePageControls `elem` opts then "hidden" else "visible" let messages = pMessages params@@ -770,8 +821,10 @@ '_':_ -> 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 ]+ , thediv ! [identifier "pageinfo"] << [ thediv ! [theclass "pageControls",+ thestyle $ "visibility: " ++ sidebarVis] <<+ ((thespan ! [theclass "details"] << revision) : buttons)+ , if isPage page then exportBox page params else noHtml] , thediv ! [identifier "footer"] << primHtml (wikiFooter cfg) ] ok $ toResponse $ head' +++ body'@@ -865,17 +918,125 @@ then do 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" })+ loginUser "/" (params { pUsername = uname, pPassword = pword }) 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+ 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 [] [] file params $ formatAsXHtml [OptNumberLines] lang' res Nothing -> noHandle++defaultRespOptions :: WriterOptions+defaultRespOptions = defaultWriterOptions { writerStandalone = True, writerWrapText = True }++respondLaTeX :: String -> Pandoc -> Web Response+respondLaTeX page = ok . setContentType "application/x-latex" . setFilename (page ++ ".tex") . toResponse .+ writeLaTeX (defaultRespOptions {writerHeader = defaultLaTeXHeader})++respondConTeXt :: String -> Pandoc -> Web Response+respondConTeXt page = ok . setContentType "application/x-context" . setFilename (page ++ ".tex") . toResponse .+ writeConTeXt (defaultRespOptions {writerHeader = defaultConTeXtHeader})++respondRTF :: String -> Pandoc -> Web Response+respondRTF page = ok . setContentType "application/rtf" . setFilename (page ++ ".rtf") . toResponse .+ writeRTF (defaultRespOptions {writerHeader = defaultRTFHeader})++respondRST :: String -> Pandoc -> Web Response+respondRST _ = ok . setContentType "text/plain" . toResponse .+ writeRST (defaultRespOptions {writerHeader = "", writerReferenceLinks = True})++respondMan :: String -> Pandoc -> Web Response+respondMan _ = ok . setContentType "text/plain" . toResponse .+ writeMan (defaultRespOptions {writerHeader = ""})++respondS5 :: String -> Pandoc -> Web Response+respondS5 _ = ok . toResponse . writeS5 (defaultRespOptions {writerHeader = defaultS5Header, + writerS5 = True, writerIncremental = True})++respondTexinfo :: String -> Pandoc -> Web Response+respondTexinfo page = ok . setContentType "application/x-texinfo" . setFilename (page ++ ".texi") . toResponse .+ writeTexinfo (defaultRespOptions {writerHeader = ""})++respondDocbook :: String -> Pandoc -> Web Response+respondDocbook page = ok . setContentType "application/docbook+xml" . setFilename (page ++ ".xml") . toResponse .+ writeDocbook (defaultRespOptions {writerHeader = defaultDocbookHeader})++respondMediaWiki :: String -> Pandoc -> Web Response+respondMediaWiki _ = ok . setContentType "text/plain" . toResponse .+ writeMediaWiki (defaultRespOptions {writerHeader = ""})++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+ B.readFile tempfile+ ok $ setContentType "application/vnd.oasis.opendocument.text" $ setFilename (page ++ ".odt") $ (toResponse noHtml) {rsBody = contents}++exportFormats :: [(String, String -> Pandoc -> Web Response)] -- (description, writer)+exportFormats = [ ("LaTeX", respondLaTeX)+ , ("ConTeXt", respondConTeXt)+ , ("Texinfo", respondTexinfo)+ , ("reST", respondRST)+ , ("MediaWiki", respondMediaWiki)+ , ("man", respondMan)+ , ("DocBook", respondDocbook)+ , ("S5", respondS5)+ , ("ODT", respondODT)+ , ("RTF", respondRTF) ]++exportBox :: String -> Params -> Html+exportBox page params =+ gui (urlForPage page) ! [identifier "exportbox"] << + [ submit "export" "Export"+ , textfield "revision" ! [thestyle "display: none;", value (pRevision params)]+ , select ! [name "format"] <<+ map ((\f -> option ! [value f] << ("as " ++ f)) . fst) exportFormats ]++rawContents :: String -> Params -> Web (Maybe String)+rawContents file params = do+ let revision = pRevision params `orIfNull` "HEAD"+ gitCatFile revision file++textToPandoc :: String -> Pandoc+textToPandoc = readMarkdown (defaultParserState { stateSanitizeHTML = True, stateSmart = True }) .+ filter (/= '\r') . decodeString++pageAsPandoc :: String -> Params -> Web (Maybe Pandoc)+pageAsPandoc page params = do+ mDoc <- rawContents (pathForPage page) params >>= (return . liftM textToPandoc)+ return $ case mDoc of+ Nothing -> Nothing+ Just (Pandoc _ blocks) -> Just $ Pandoc (Meta [Str page] [] []) blocks++exportPage :: String -> Params -> Web Response+exportPage page params = do+ let format = pFormat params+ mDoc <- pageAsPandoc page params+ case mDoc of+ Nothing -> error $ "Unable to retrieve page contents."+ Just doc -> case lookup format exportFormats of+ Nothing -> error $ "Unknown export format: " ++ format+ Just writer -> writer page doc++-- | Perform a function in a temporary directory and clean up.+withTempDir :: FilePath -> (FilePath -> IO a) -> IO a+withTempDir baseName = bracket (createTempDir 0 baseName) (removeDirectoryRecursive)++-- | Create a temporary directory with a unique name.+createTempDir :: Integer -> FilePath -> IO FilePath+createTempDir num baseName = do+ sysTempDir <- catch getTemporaryDirectory (\_ -> return ".")+ let dirName = sysTempDir </> baseName <.> show num+ catch (createDirectory dirName >> return dirName) $+ \e -> if isAlreadyExistsError e+ then createTempDir (num + 1) baseName+ else ioError e
Gitit/State.hs view
@@ -47,6 +47,7 @@ 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?+ frontPage :: String, -- the front page of the wiki 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.@@ -66,6 +67,7 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = False,+ frontPage = "Front Page", noEdit = ["Help"], noDelete = ["Help", "Front Page"], accessQuestion = Nothing
README.markdown view
@@ -95,6 +95,7 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = True,+ frontPage = ["Front Page"], noEdit = ["Help"], noDelete = ["Help", "Front Page"], accessQuestion = Just ("Enter the access code (to request a code, contact me@foo.bar.com):", ["abcd"])@@ -114,6 +115,8 @@ - `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.+- `frontPage` specifies the front page of the wiki (which will be displayed at+ the root URL). - 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,6 +9,7 @@ portNumber = 5001, passwordSalt = "l91snthoae8eou2340987", debugMode = True,+frontPage = "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.2.1+version: 0.2.2 Cabal-version: >= 1.2 build-type: Simple synopsis: Wiki using HAppS, git, and pandoc.
stylesheets/gitit.css view
@@ -178,6 +178,7 @@ color: #888; font-size: .85em; margin-left: 0.3em;+ margin-right: 1em; } span.detail { color: #888;