module Network.Gitit.ContentTransformer
(
runPageTransformer
, runFileTransformer
, showRawPage
, showFileAsText
, showPage
, exportPage
, showHighlightedSource
, showFile
, preview
, applyPreCommitPlugins
, cacheHtml
, cachedHtml
, rawContents
, textResponse
, mimeFileResponse
, mimeResponse
, exportPandoc
, applyWikiTemplate
, pageToWikiPandoc
, pageToPandoc
, pandocToHtml
, highlightSource
, applyPageTransforms
, wikiDivify
, addPageTitleToPandoc
, addMathSupport
, addScripts
, getFileName
, getPageName
, getLayout
, getParams
, getCacheable
, inlinesToURL
, inlinesToString
)
where
import Prelude hiding (catch)
import Network.Gitit.Server
import Network.Gitit.Framework
import Network.Gitit.State
import Network.Gitit.Types
import Network.Gitit.Layout
import Network.Gitit.Export (exportFormats)
import Network.Gitit.Page (stringToPage)
import Network.Gitit.Cache (lookupCache, cacheContents)
import qualified Data.FileStore as FS
import Data.Maybe (mapMaybe)
import Text.Pandoc hiding (MathML, WebTeX)
import qualified Text.Pandoc as Pandoc
import Text.Pandoc.Shared (ObfuscationMethod(..))
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import Text.Highlighting.Kate
import Data.Maybe (isNothing)
import System.FilePath
import Control.Monad.State
import Control.Exception (throwIO, catch)
import qualified Data.ByteString as S (concat)
import qualified Data.ByteString.Lazy as L (toChunks, fromChunks)
import Network.URL (encString)
import Network.URI (isUnescapedInURI)
import Text.HTML.SanitizeXSS (sanitizeBalance)
runTransformer :: ToMessage a
=> (String -> String)
-> ContentTransformer a
-> GititServerPart a
runTransformer pathFor xform = withData $ \params -> do
page <- getPage
cfg <- getConfig
evalStateT xform Context{ ctxFile = pathFor page
, ctxLayout = defaultPageLayout{
pgPageName = page
, pgTitle = page
, pgPrintable = pPrintable params
, pgMessages = pMessages params
, pgRevision = pRevision params
, pgLinkToFeed = useFeed cfg }
, ctxCacheable = True
, ctxTOC = tableOfContents cfg
, ctxBirdTracks = showLHSBirdTracks cfg
, ctxCategories = []
, ctxMeta = [] }
runPageTransformer :: ToMessage a
=> ContentTransformer a
-> GititServerPart a
runPageTransformer = runTransformer pathForPage
runFileTransformer :: ToMessage a
=> ContentTransformer a
-> GititServerPart a
runFileTransformer = runTransformer id
showRawPage :: Handler
showRawPage = runPageTransformer rawTextResponse
showFileAsText :: Handler
showFileAsText = runFileTransformer rawTextResponse
showPage :: Handler
showPage = runPageTransformer htmlViaPandoc
exportPage :: Handler
exportPage = runPageTransformer exportViaPandoc
showHighlightedSource :: Handler
showHighlightedSource = runFileTransformer highlightRawSource
showFile :: Handler
showFile = runFileTransformer (rawContents >>= mimeFileResponse)
preview :: Handler
preview = runPageTransformer $
liftM (filter (/= '\r') . pRaw) getParams >>=
contentsToPage >>=
pageToWikiPandoc >>=
pandocToHtml >>=
return . toResponse . renderHtmlFragment
applyPreCommitPlugins :: String -> GititServerPart String
applyPreCommitPlugins = runPageTransformer . applyPreCommitTransforms
rawTextResponse :: ContentTransformer Response
rawTextResponse = rawContents >>= textResponse
exportViaPandoc :: ContentTransformer Response
exportViaPandoc = rawContents >>=
maybe mzero return >>=
contentsToPage >>=
pageToWikiPandoc >>=
exportPandoc
htmlViaPandoc :: ContentTransformer Response
htmlViaPandoc = cachedHtml `mplus`
(rawContents >>=
maybe mzero return >>=
contentsToPage >>=
pageToWikiPandoc >>=
addMathSupport >>=
pandocToHtml >>=
wikiDivify >>=
applyWikiTemplate >>=
cacheHtml)
highlightRawSource :: ContentTransformer Response
highlightRawSource =
cachedHtml `mplus`
(updateLayout (\l -> l { pgTabs = [ViewTab,HistoryTab] }) >>
rawContents >>=
highlightSource >>=
applyWikiTemplate >>=
cacheHtml)
cacheHtml :: Response -> ContentTransformer Response
cacheHtml resp' = do
params <- getParams
file <- getFileName
cacheable <- getCacheable
cfg <- lift getConfig
when (useCache cfg && cacheable && isNothing (pRevision params) && not (pPrintable params)) $
lift $ cacheContents file $ S.concat $ L.toChunks $ rsBody resp'
return resp'
cachedHtml :: ContentTransformer Response
cachedHtml = do
file <- getFileName
params <- getParams
cfg <- lift getConfig
if useCache cfg && not (pPrintable params) && isNothing (pRevision params)
then do mbCached <- lift $ lookupCache file
let emptyResponse = setContentType "text/html; charset=utf-8" . toResponse $ ()
maybe mzero (\(_modtime, contents) -> lift . ok $ emptyResponse{rsBody = L.fromChunks [contents]}) mbCached
else mzero
rawContents :: ContentTransformer (Maybe String)
rawContents = do
params <- getParams
file <- getFileName
fs <- lift getFileStore
let rev = pRevision params
liftIO $ catch (liftM Just $ FS.retrieve fs file rev)
(\e -> if e == FS.NotFound then return Nothing else throwIO e)
textResponse :: Maybe String -> ContentTransformer Response
textResponse Nothing = mzero
textResponse (Just c) = mimeResponse c "text/plain; charset=utf-8"
mimeFileResponse :: Maybe String -> ContentTransformer Response
mimeFileResponse Nothing = error "Unable to retrieve file contents."
mimeFileResponse (Just c) =
mimeResponse c =<< lift . getMimeTypeForExtension . takeExtension =<< getFileName
mimeResponse :: Monad m
=> String
-> String
-> m Response
mimeResponse c mimeType =
return . setContentType mimeType . toResponse $ c
exportPandoc :: Pandoc -> ContentTransformer Response
exportPandoc doc = do
params <- getParams
page <- getPageName
cfg <- lift getConfig
let format = pFormat params
case lookup format (exportFormats cfg) of
Nothing -> error $ "Unknown export format: " ++ format
Just writer -> lift (writer page doc)
applyWikiTemplate :: Html -> ContentTransformer Response
applyWikiTemplate c = do
Context { ctxLayout = layout } <- get
lift $ formattedPage layout c
pageToWikiPandoc :: Page -> ContentTransformer Pandoc
pageToWikiPandoc page' =
pageToWikiPandoc' page' >>= addPageTitleToPandoc (pageTitle page')
pageToWikiPandoc' :: Page -> ContentTransformer Pandoc
pageToWikiPandoc' = applyPreParseTransforms >=>
pageToPandoc >=> applyPageTransforms
pageToPandoc :: Page -> ContentTransformer Pandoc
pageToPandoc page' = do
modifyContext $ \ctx -> ctx{ ctxTOC = pageTOC page'
, ctxCategories = pageCategories page'
, ctxMeta = pageMeta page' }
return $ readerFor (pageFormat page') (pageLHS page') (pageText page')
contentsToPage :: String -> ContentTransformer Page
contentsToPage s = do
cfg <- lift getConfig
pn <- getPageName
return $ stringToPage cfg pn s
pandocToHtml :: Pandoc -> ContentTransformer Html
pandocToHtml pandocContents = do
base' <- lift getWikiBase
toc <- liftM ctxTOC get
bird <- liftM ctxBirdTracks get
cfg <- lift getConfig
return $ primHtml $ sanitizeBalance $
writeHtmlString defaultWriterOptions{
writerStandalone = True
, writerTemplate = "$if(toc)$\n$toc$\n$endif$\n$body$"
, writerHTMLMathMethod =
case mathMethod cfg of
MathML -> Pandoc.MathML Nothing
WebTeX u -> Pandoc.WebTeX u
_ -> JsMath (Just $ base' ++
"/js/jsMath/easy/load.js")
, writerTableOfContents = toc
, writerLiterateHaskell = bird
, writerEmailObfuscation = ReferenceObfuscation
} pandocContents
highlightSource :: Maybe String -> ContentTransformer Html
highlightSource Nothing = mzero
highlightSource (Just source) = do
file <- getFileName
let formatOpts = [OptNumberLines, OptLineAnchors]
case languagesByExtension $ takeExtension file of
[] -> mzero
(l:_) -> case highlightAs l (filter (/='\r') source) of
Left _ -> mzero
Right res -> return $ formatAsXHtml formatOpts l $! res
getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms = liftM (mapMaybe pageTransform) $ queryGititState plugins
where pageTransform (PageTransform x) = Just x
pageTransform _ = Nothing
getPreParseTransforms :: ContentTransformer [String -> PluginM String]
getPreParseTransforms = liftM (mapMaybe preParseTransform) $
queryGititState plugins
where preParseTransform (PreParseTransform x) = Just x
preParseTransform _ = Nothing
getPreCommitTransforms :: ContentTransformer [String -> PluginM String]
getPreCommitTransforms = liftM (mapMaybe preCommitTransform) $
queryGititState plugins
where preCommitTransform (PreCommitTransform x) = Just x
preCommitTransform _ = Nothing
applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a
applyTransform inp transform = do
context <- get
conf <- lift getConfig
user <- lift getLoggedInUser
fs <- lift getFileStore
req <- lift askRq
let pluginData = PluginData{ pluginConfig = conf
, pluginUser = user
, pluginRequest = req
, pluginFileStore = fs }
(result', context') <- liftIO $ runPluginM (transform inp) pluginData context
put context'
return result'
applyPageTransforms :: Pandoc -> ContentTransformer Pandoc
applyPageTransforms c = do
xforms <- getPageTransforms
foldM applyTransform c (wikiLinksTransform : xforms)
applyPreParseTransforms :: Page -> ContentTransformer Page
applyPreParseTransforms page' = getPreParseTransforms >>= foldM applyTransform (pageText page') >>=
(\t -> return page'{ pageText = t })
applyPreCommitTransforms :: String -> ContentTransformer String
applyPreCommitTransforms c = getPreCommitTransforms >>= foldM applyTransform c
wikiDivify :: Html -> ContentTransformer Html
wikiDivify c = do
categories <- liftM ctxCategories get
base' <- lift getWikiBase
let categoryLink ctg = li (anchor ! [href $ base' ++ "/_category/" ++ ctg] << ctg)
let htmlCategories = if null categories
then noHtml
else thediv ! [identifier "categoryList"] << ulist << map categoryLink categories
return $ thediv ! [identifier "wikipage"] << [c, htmlCategories]
addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc
addPageTitleToPandoc title' (Pandoc _ blocks) = do
updateLayout $ \layout -> layout{ pgTitle = title' }
return $ if null title'
then Pandoc (Meta [] [] []) blocks
else Pandoc (Meta [Str title'] [] []) blocks
addMathSupport :: a -> ContentTransformer a
addMathSupport c = do
conf <- lift getConfig
updateLayout $ \l ->
case mathMethod conf of
JsMathScript -> addScripts l ["jsMath/easy/load.js"]
MathML -> addScripts l ["MathMLinHTML.js"]
WebTeX _ -> l
RawTeX -> l
return c
addScripts :: PageLayout -> [String] -> PageLayout
addScripts layout scriptPaths =
layout{ pgScripts = scriptPaths ++ pgScripts layout }
getParams :: ContentTransformer Params
getParams = lift (withData return)
getFileName :: ContentTransformer FilePath
getFileName = liftM ctxFile get
getPageName :: ContentTransformer String
getPageName = liftM (pgPageName . ctxLayout) get
getLayout :: ContentTransformer PageLayout
getLayout = liftM ctxLayout get
getCacheable :: ContentTransformer Bool
getCacheable = liftM ctxCacheable get
updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout f = do
ctx <- get
let l = ctxLayout ctx
put ctx { ctxLayout = f l }
readerFor :: PageType -> Bool -> (String -> Pandoc)
readerFor pt lhs =
let defPS = defaultParserState{ stateSmart = True
, stateLiterateHaskell = lhs }
in case pt of
RST -> readRST defPS
Markdown -> readMarkdown defPS
LaTeX -> readLaTeX defPS
HTML -> readHtml defPS
Textile -> readTextile defPS
wikiLinksTransform :: Pandoc -> PluginM Pandoc
wikiLinksTransform = return . bottomUp convertWikiLinks
convertWikiLinks :: Inline -> Inline
convertWikiLinks (Link ref ("", "")) =
Link ref (inlinesToURL ref, "Go to wiki page")
convertWikiLinks x = x
inlinesToURL :: [Inline] -> String
inlinesToURL = encString False isUnescapedInURI . inlinesToString
inlinesToString :: [Inline] -> String
inlinesToString = concatMap go
where go x = case x of
Str s -> s
Emph xs -> concatMap go xs
Strong xs -> concatMap go xs
Strikeout xs -> concatMap go xs
Superscript xs -> concatMap go xs
Subscript xs -> concatMap go xs
SmallCaps xs -> concatMap go xs
Quoted DoubleQuote xs -> '"' : (concatMap go xs ++ "\"")
Quoted SingleQuote xs -> '\'' : (concatMap go xs ++ "'")
Cite _ xs -> concatMap go xs
Code _ s -> s
Space -> " "
EmDash -> "---"
EnDash -> "--"
Apostrophe -> "'"
Ellipses -> "..."
LineBreak -> " "
Math DisplayMath s -> "$$" ++ s ++ "$$"
Math InlineMath s -> "$" ++ s ++ "$"
RawInline "tex" s -> s
RawInline _ _ -> ""
Link xs _ -> concatMap go xs
Image xs _ -> concatMap go xs
Note _ -> ""