diff --git a/Gitit.hs b/Gitit.hs --- a/Gitit.hs +++ b/Gitit.hs @@ -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 diff --git a/Gitit/State.hs b/Gitit/State.hs --- a/Gitit/State.hs +++ b/Gitit/State.hs @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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 diff --git a/data/SampleConfig.hs b/data/SampleConfig.hs --- a/data/SampleConfig.hs +++ b/data/SampleConfig.hs @@ -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"]) diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -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. diff --git a/stylesheets/gitit.css b/stylesheets/gitit.css --- a/stylesheets/gitit.css +++ b/stylesheets/gitit.css @@ -178,6 +178,7 @@ color: #888; font-size: .85em; margin-left: 0.3em; + margin-right: 1em; } span.detail { color: #888;