From 785ff36fb489c57630d60ff7a80a3459e7a108fa Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Wed, 23 May 2012 12:01:25 -0700 Subject: [PATCH] Got view working for source and other files as well as pages. --- Network/Gitit2.hs | 61 ++++++++++++++++++++++++++++++++++++++++------- gitit2.cabal | 3 +++ src/gitit2.hs | 28 +++++++++++++++++++++- 3 files changed, 82 insertions(+), 10 deletions(-) diff --git a/Network/Gitit2.hs b/Network/Gitit2.hs index f20496f..313f932 100644 --- a/Network/Gitit2.hs +++ b/Network/Gitit2.hs @@ -16,6 +16,7 @@ module Network.Gitit2 ( GititConfig (..) ) where import Prelude hiding (catch) +import qualified Data.Map as M import Yesod hiding (MsgDelete) import Yesod.Static import Yesod.Default.Handlers -- robots, favicon @@ -37,6 +38,7 @@ import Data.Monoid (Monoid, mappend) import Data.Maybe (mapMaybe) import System.Random (randomRIO) import Control.Exception (throw, handle, try) +import Text.Highlighting.Kate -- This is defined in GHC 7.04+, but for compatibility we define it here. infixr 5 <> @@ -56,6 +58,7 @@ instance Yesod Gitit -- | Configuration for a gitit wiki. data GititConfig = GititConfig{ wiki_path :: FilePath -- ^ Path to the repository. + , mime_types :: M.Map String ContentType -- ^ Table of mime types } -- | Path to a wiki page. Pages can't begin with '_'. @@ -299,6 +302,12 @@ isDiscussPageFile :: FilePath -> GHandler Gitit master Bool isDiscussPageFile ('@':xs) = isPageFile xs isDiscussPageFile _ = return False +isSourceFile :: FilePath -> GHandler Gitit master Bool +isSourceFile path' = do + let langs = languagesByFilename $ takeFileName path' + return $ not (null langs || takeExtension path' == ".svg") + -- allow svg to be served as image + -- TODO : make the front page configurable getHomeR :: HasGitit master => GHandler Gitit master RepHtml getHomeR = getViewR (Page "Front Page") @@ -323,7 +332,12 @@ getRawR page = do path <- pathForPage page mbcont <- getRawContents path Nothing case mbcont of - Nothing -> notFound + Nothing -> do + path' <- pathForFile page + mbcont' <- getRawContents path' Nothing + case mbcont' of + Nothing -> notFound + Just (_,cont) -> return $ RepPlain $ toContent cont Just (_,cont) -> return $ RepPlain $ toContent cont getDeleteR :: HasGitit master => Page -> GHandler Gitit master RepHtml @@ -380,20 +394,37 @@ view mbrev page = do path <- pathForPage page mbcont <- getRawContents path mbrev case mbcont of - Nothing -> do setMessageI (MsgNewPage page) - redirect (toMaster $ EditR page) Just (_,contents) -> do - htmlContents <- contentsToHtml contents + htmlContents <- pageToHtml contents + layout [ViewTab,EditTab,HistoryTab,DiscussTab] htmlContents + Nothing -> do + path' <- pathForFile page + mbcont' <- getRawContents path' mbrev + is_source <- isSourceFile path' + case mbcont' of + Nothing -> do + setMessageI (MsgNewPage page) + redirect (toMaster $ EditR page) + Just (_,contents) + | is_source -> do + htmlContents <- sourceToHtml path' contents + layout [ViewTab,HistoryTab] htmlContents + | otherwise -> do + mimeTypes <- mime_types <$> config <$> getYesodSub + let ct = maybe "application/octet-stream" id + $ M.lookup (drop 1 $ takeExtension path') mimeTypes + sendResponse (ct, toContent contents) + where layout tabs cont = makePage pageLayout{ pgName = Just page , pgPageTools = True - , pgTabs = [ViewTab,EditTab,HistoryTab,DiscussTab] + , pgTabs = tabs , pgSelectedTab = ViewTab } $ do setTitle $ toMarkup page [whamlet|

#{page} $maybe rev <- mbrev

#{rev} - ^{toWikiPage htmlContents} + ^{toWikiPage cont} |] getIndexR :: HasGitit master => Dir -> GHandler Gitit master RepHtml @@ -436,7 +467,10 @@ upDir toMaster fs = do [] -> "\x2302" [whamlet|#{lastdir}/|] -getRawContents :: HasGitit master => FilePath -> Maybe RevisionId -> GHandler Gitit master (Maybe (RevisionId, ByteString)) +getRawContents :: HasGitit master + => FilePath + -> Maybe RevisionId + -> GHandler Gitit master (Maybe (RevisionId, ByteString)) getRawContents path rev = do fs <- filestore <$> getYesodSub liftIO $ handle (\e -> if e == FS.NotFound then return Nothing else throw e) @@ -444,8 +478,8 @@ getRawContents path rev = do cont <- retrieve fs path rev return $ Just (revid, cont) -contentsToHtml :: HasGitit master => ByteString -> GHandler Gitit master Html -contentsToHtml contents = do +pageToHtml :: HasGitit master => ByteString -> GHandler Gitit master Html +pageToHtml contents = do let doc = readMarkdown defaultParserState{ stateSmart = True } $ toString contents doc' <- sanitizePandoc <$> addWikiLinks doc let rendered = writeHtml defaultWriterOptions{ @@ -455,6 +489,15 @@ contentsToHtml contents = do , writerHTMLMathMethod = MathJax $ T.unpack mathjax_url } doc' return rendered +sourceToHtml :: HasGitit master + => FilePath -> ByteString -> GHandler Gitit master Html +sourceToHtml path contents = do + let formatOpts = defaultFormatOpts { numberLines = True, lineAnchors = True } + return $ formatHtmlBlock formatOpts $ + case languagesByExtension $ takeExtension path of + [] -> highlightAs "" $ toString contents + (l:_) -> highlightAs l $ toString contents + -- TODO replace with something in configuration. mathjax_url :: Text mathjax_url = "https://d3eoax9i5htok0.cloudfront.net/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" diff --git a/gitit2.cabal b/gitit2.cabal index 547ed24..404d488 100644 --- a/gitit2.cabal +++ b/gitit2.cabal @@ -61,7 +61,9 @@ library , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5 && < 0.6 , random >= 1.0 && < 1.1 + , containers >= 0.4 && < 0.5 , pandoc >= 1.9.3 && < 1.10 + , highlighting-kate >= 0.5.0.6 && < 0.6 , xss-sanitize >= 0.3.2 && < 0.4 ghc-options: -Wall -threaded -fno-warn-unused-do-bind @@ -73,6 +75,7 @@ executable gitit2 , yesod >= 1.0 && < 1.1 , yesod-static >= 1.0 && < 1.1 , filestore >= 0.4 && < 0.5 + , containers >= 0.4 && < 0.5 , gitit2 ghc-options: -Wall -threaded -fno-warn-unused-do-bind if flag(executable) diff --git a/src/gitit2.hs b/src/gitit2.hs index 44b5ba7..ff30bbc 100644 --- a/src/gitit2.hs +++ b/src/gitit2.hs @@ -4,6 +4,7 @@ import Network.Gitit2 import Yesod import Yesod.Static import Data.FileStore +import qualified Data.Map as M data Master = Master { getGitit :: Gitit } mkYesod "Master" [parseRoutes| @@ -38,9 +39,34 @@ instance HasGitit Master where requireUser = return $ GititUser "Dummy" "dumb@dumber.org" makePage = makeDefaultPage +-- | Ready collection of common mime types. (Copied from +-- Happstack.Server.HTTP.FileServe.) +mimeTypes :: M.Map String ContentType +mimeTypes = M.fromList + [("xml","application/xml") + ,("xsl","application/xml") + ,("js","text/javascript") + ,("html","text/html") + ,("htm","text/html") + ,("css","text/css") + ,("gif","image/gif") + ,("jpg","image/jpeg") + ,("png","image/png") + ,("txt","text/plain; charset=UTF-8") + ,("doc","application/msword") + ,("exe","application/octet-stream") + ,("pdf","application/pdf") + ,("zip","application/zip") + ,("gz","application/x-gzip") + ,("ps","application/postscript") + ,("rtf","application/rtf") + ,("wav","application/x-wav") + ,("hs","text/plain")] + main :: IO () main = do - let conf = GititConfig{ wiki_path = "wikidata" } + let conf = GititConfig{ wiki_path = "wikidata" + , mime_types = mimeTypes } let fs = gitFileStore $ wiki_path conf st <- staticDevel "static" warpDebug 3000 $ Master (Gitit{ config = conf