{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
Anton van Straaten <anton@appsolutions.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- Functions for content conversion.
-}

module Network.Gitit.ContentTransformer
  (
  -- * ContentTransformer runners
    runPageTransformer
  , runFileTransformer
  -- * Gitit responders
  , showRawPage
  , showFileAsText
  , showPage
  , showHighlightedSource
  , showFile
  , preview
  , applyPreCommitPlugins
  -- * Cache support for transformers
  , cacheHtml
  , cachedHtml
  -- * Content retrieval combinators
  , rawContents
  -- * Response-generating combinators
  , textResponse
  , mimeFileResponse
  , mimeResponse
  , applyWikiTemplate
  -- * Content-type transformation combinators
  , pageToWikiPandoc
  , pageToPandoc
  , pandocToHtml
  , highlightSource
  -- * Content or context augmentation combinators
  , applyPageTransforms
  , wikiDivify
  , addPageTitleToPandoc
  , addMathSupport
  , addScripts
  -- * ContentTransformer context API
  , getFileName
  , getPageName
  , getLayout
  , getParams
  , getCacheable
  -- * Pandoc and wiki content conversion support
  , inlinesToURL
  , inlinesToString
  )
where

import qualified Control.Exception as E
import Control.Monad.State
import Control.Monad.Reader (ask)
import Control.Monad.Except (throwError)
import Data.Foldable (traverse_)
import Data.List (stripPrefix)
import Data.Maybe (isNothing, mapMaybe)
import Data.Semigroup ((<>))
import Network.Gitit.Cache (lookupCache, cacheContents)
import Network.Gitit.Framework hiding (uriPath)
import Network.Gitit.Layout
import Network.Gitit.Page (stringToPage)
import Network.Gitit.Server
import Network.Gitit.State
import Network.Gitit.Types
import Network.Gitit.Util (getPageTypeDefaultExtensions)
import Network.HTTP (urlDecode)
import Network.URI (isUnescapedInURI)
import Network.URL (encString)
import System.FilePath
import qualified Text.Pandoc.Builder as B
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Skylighting hiding (Context)
import Text.Pandoc hiding (MathML, WebTeX, MathJax)
import Text.XHtml hiding ( (</>), dir, method, password, rev )
import Text.XHtml.Strict (stringToHtmlString)
#if MIN_VERSION_blaze_html(0,5,0)
import Text.Blaze.Html.Renderer.String as Blaze ( renderHtml )
#else
import Text.Blaze.Renderer.String as Blaze ( renderHtml )
#endif
import URI.ByteString (Query(Query), URIRef(uriPath), laxURIParserOptions,
                       parseURI, uriQuery)
import qualified Data.Text as T
import qualified Data.ByteString as S (concat)
import qualified Data.ByteString.Char8 as SC (pack, unpack)
import qualified Data.ByteString.Lazy as L (toChunks, fromChunks)
import qualified Data.FileStore as FS
import qualified Text.Pandoc as Pandoc

--
-- ContentTransformer runners
--

runPageTransformer :: ToMessage a
               => ContentTransformer a
               -> GititServerPart a
runPageTransformer :: forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer a
xform = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ContentTransformer a
xform  Context{ ctxFile :: String
ctxFile = String -> String -> String
pathForPage String
page (Config -> String
defaultExtension Config
cfg)
                           , ctxLayout :: PageLayout
ctxLayout = PageLayout
defaultPageLayout{
                                             pgPageName :: String
pgPageName = String
page
                                           , pgTitle :: String
pgTitle = String
page
                                           , pgPrintable :: Bool
pgPrintable = Params -> Bool
pPrintable Params
params
                                           , pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params
                                           , pgRevision :: Maybe String
pgRevision = Params -> Maybe String
pRevision Params
params
                                           , pgLinkToFeed :: Bool
pgLinkToFeed = Config -> Bool
useFeed Config
cfg }
                           , ctxCacheable :: Bool
ctxCacheable = Bool
True
                           , ctxTOC :: Bool
ctxTOC = Config -> Bool
tableOfContents Config
cfg
                           , ctxBirdTracks :: Bool
ctxBirdTracks = Config -> Bool
showLHSBirdTracks Config
cfg
                           , ctxCategories :: [String]
ctxCategories = []
                           , ctxMeta :: [(String, String)]
ctxMeta = [] }

runFileTransformer :: ToMessage a
               => ContentTransformer a
               -> GititServerPart a
runFileTransformer :: forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer a
xform = forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall a b. (a -> b) -> a -> b
$ \Params
params -> do
  String
page <- GititServerPart String
getPage
  Config
cfg <- GititServerPart Config
getConfig
  forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ContentTransformer a
xform  Context{ ctxFile :: String
ctxFile = forall a. a -> a
id String
page
                           , ctxLayout :: PageLayout
ctxLayout = PageLayout
defaultPageLayout{
                                             pgPageName :: String
pgPageName = String
page
                                           , pgTitle :: String
pgTitle = String
page
                                           , pgPrintable :: Bool
pgPrintable = Params -> Bool
pPrintable Params
params
                                           , pgMessages :: [String]
pgMessages = Params -> [String]
pMessages Params
params
                                           , pgRevision :: Maybe String
pgRevision = Params -> Maybe String
pRevision Params
params
                                           , pgLinkToFeed :: Bool
pgLinkToFeed = Config -> Bool
useFeed Config
cfg }
                           , ctxCacheable :: Bool
ctxCacheable = Bool
True
                           , ctxTOC :: Bool
ctxTOC = Config -> Bool
tableOfContents Config
cfg
                           , ctxBirdTracks :: Bool
ctxBirdTracks = Config -> Bool
showLHSBirdTracks Config
cfg
                           , ctxCategories :: [String]
ctxCategories = []
                           , ctxMeta :: [(String, String)]
ctxMeta = [] }

-- | Converts a @ContentTransformer@ into a @GititServerPart@;
-- specialized to wiki pages.
-- runPageTransformer :: ToMessage a
--                    => ContentTransformer a
--                    -> GititServerPart a
-- runPageTransformer = runTransformer pathForPage

-- | Converts a @ContentTransformer@ into a @GititServerPart@;
-- specialized to non-pages.
-- runFileTransformer :: ToMessage a
--                    => ContentTransformer a
--                    -> GititServerPart a
-- runFileTransformer = runTransformer id

--
-- Gitit responders
--

-- | Responds with raw page source.
showRawPage :: Handler
showRawPage :: Handler
showRawPage = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer Response
rawTextResponse

-- | Responds with raw source (for non-pages such as source
-- code files).
showFileAsText :: Handler
showFileAsText :: Handler
showFileAsText = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer Response
rawTextResponse

-- | Responds with rendered wiki page.
showPage :: Handler
showPage :: Handler
showPage = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer ContentTransformer Response
htmlViaPandoc

-- | Responds with highlighted source code.
showHighlightedSource :: Handler
showHighlightedSource :: Handler
showHighlightedSource = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer ContentTransformer Response
highlightRawSource

-- | Responds with non-highlighted source code.
showFile :: Handler
showFile :: Handler
showFile = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runFileTransformer (ContentTransformer (Maybe String)
rawContents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> ContentTransformer Response
mimeFileResponse)

-- | Responds with rendered page derived from form data.
preview :: Handler
preview :: Handler
preview = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> String
pRaw) ContentTransformer Params
getParams forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          String -> StateT Context GititServerPart Page
contentsToPage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          Pandoc -> StateT Context GititServerPart Html
pandocToHtml forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall html. HTML html => html -> String
renderHtmlFragment

-- | Applies pre-commit plugins to raw page source, possibly
-- modifying it.
applyPreCommitPlugins :: String -> GititServerPart String
applyPreCommitPlugins :: String -> GititServerPart String
applyPreCommitPlugins = forall a. ToMessage a => ContentTransformer a -> GititServerPart a
runPageTransformer forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ContentTransformer String
applyPreCommitTransforms

--
-- Top level, composed transformers
--

-- | Responds with raw source.
rawTextResponse :: ContentTransformer Response
rawTextResponse :: ContentTransformer Response
rawTextResponse = ContentTransformer (Maybe String)
rawContents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> ContentTransformer Response
textResponse

-- | Responds with a wiki page. Uses the cache when
-- possible and caches the rendered page when appropriate.
htmlViaPandoc :: ContentTransformer Response
htmlViaPandoc :: ContentTransformer Response
htmlViaPandoc = ContentTransformer Response
cachedHtml forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  (ContentTransformer (Maybe String)
rawContents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   String -> StateT Context GititServerPart Page
contentsToPage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   Page -> StateT Context GititServerPart (Either Response Page)
handleRedirects forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return
                     (Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      forall a. a -> ContentTransformer a
addMathSupport forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Pandoc -> StateT Context GititServerPart Html
pandocToHtml forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Html -> StateT Context GititServerPart Html
wikiDivify forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Html -> ContentTransformer Response
applyWikiTemplate forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                      Response -> ContentTransformer Response
cacheHtml))

-- | Responds with highlighted source code in a wiki
-- page template.  Uses the cache when possible and
-- caches the rendered page when appropriate.
highlightRawSource :: ContentTransformer Response
highlightRawSource :: ContentTransformer Response
highlightRawSource =
  ContentTransformer Response
cachedHtml forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    ((PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout (\PageLayout
l -> PageLayout
l { pgTabs :: [Tab]
pgTabs = [Tab
ViewTab,Tab
HistoryTab] }) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
     ContentTransformer (Maybe String)
rawContents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Maybe String -> StateT Context GititServerPart Html
highlightSource forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Html -> ContentTransformer Response
applyWikiTemplate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
     Response -> ContentTransformer Response
cacheHtml)

--
-- Cache support for transformers
--

-- | Caches a response (actually just the response body) on disk,
-- unless the context indicates that the page is not cacheable.
cacheHtml :: Response -> ContentTransformer Response
cacheHtml :: Response -> ContentTransformer Response
cacheHtml Response
resp' = do
  Params
params <- ContentTransformer Params
getParams
  String
file <- ContentTransformer String
getFileName
  Bool
cacheable <- ContentTransformer Bool
getCacheable
  Config
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
useCache Config
cfg Bool -> Bool -> Bool
&& Bool
cacheable Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Params -> Maybe String
pRevision Params
params) Bool -> Bool -> Bool
&& Bool -> Bool
not (Params -> Bool
pPrintable Params
params)) forall a b. (a -> b) -> a -> b
$
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> ByteString -> GititServerPart ()
cacheContents String
file forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S.concat forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rsBody Response
resp'
  forall (m :: * -> *) a. Monad m => a -> m a
return Response
resp'

-- | Returns cached page if available, otherwise mzero.
cachedHtml :: ContentTransformer Response
cachedHtml :: ContentTransformer Response
cachedHtml = do
  String
file <- ContentTransformer String
getFileName
  Params
params <- ContentTransformer Params
getParams
  Config
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  if Config -> Bool
useCache Config
cfg Bool -> Bool -> Bool
&& Bool -> Bool
not (Params -> Bool
pPrintable Params
params) Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Params -> Maybe String
pRevision Params
params)
     then do Maybe (UTCTime, ByteString)
mbCached <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> GititServerPart (Maybe (UTCTime, ByteString))
lookupCache String
file
             let emptyResponse :: Response
emptyResponse = String -> Response -> Response
setContentType String
"text/html; charset=utf-8" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse forall a b. (a -> b) -> a -> b
$ ()
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero (\(UTCTime
_modtime, ByteString
contents) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok forall a b. (a -> b) -> a -> b
$ Response
emptyResponse{rsBody :: ByteString
rsBody = [ByteString] -> ByteString
L.fromChunks [ByteString
contents]}) Maybe (UTCTime, ByteString)
mbCached
     else forall (m :: * -> *) a. MonadPlus m => m a
mzero

--
-- Content retrieval combinators
--

-- | Returns raw file contents.
rawContents :: ContentTransformer (Maybe String)
rawContents :: ContentTransformer (Maybe String)
rawContents = do
  Params
params <- ContentTransformer Params
getParams
  String
file <- ContentTransformer String
getFileName
  FileStore
fs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart FileStore
getFileStore
  let rev :: Maybe String
rev = Params -> Maybe String
pRevision Params
params
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FileStore -> forall a. Contents a => String -> Maybe String -> IO a
FS.retrieve FileStore
fs String
file Maybe String
rev)
               (\FileStoreError
e -> if FileStoreError
e forall a. Eq a => a -> a -> Bool
== FileStoreError
FS.NotFound then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else forall e a. Exception e => e -> IO a
E.throwIO FileStoreError
e)

--
-- Response-generating combinators
--

-- | Converts raw contents to a text/plain response.
textResponse :: Maybe String -> ContentTransformer Response
textResponse :: Maybe String -> ContentTransformer Response
textResponse Maybe String
Nothing  = forall (m :: * -> *) a. MonadPlus m => m a
mzero  -- fail quietly if file not found
textResponse (Just String
c) = forall (m :: * -> *). Monad m => String -> String -> m Response
mimeResponse String
c String
"text/plain; charset=utf-8"

-- | Converts raw contents to a response that is appropriate with
-- a mime type derived from the page's extension.
mimeFileResponse :: Maybe String -> ContentTransformer Response
mimeFileResponse :: Maybe String -> ContentTransformer Response
mimeFileResponse Maybe String
Nothing = forall a. HasCallStack => String -> a
error String
"Unable to retrieve file contents."
mimeFileResponse (Just String
c) =
  forall (m :: * -> *). Monad m => String -> String -> m Response
mimeResponse String
c forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GititServerPart String
getMimeTypeForExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ContentTransformer String
getFileName

mimeResponse :: Monad m
             => String        -- ^ Raw contents for response body
             -> String        -- ^ Mime type
             -> m Response
mimeResponse :: forall (m :: * -> *). Monad m => String -> String -> m Response
mimeResponse String
c String
mimeType =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Response -> Response
setContentType String
mimeType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse forall a b. (a -> b) -> a -> b
$ String
c

-- | Adds the sidebar, page tabs, and other elements of the wiki page
-- layout to the raw content.
applyWikiTemplate :: Html -> ContentTransformer Response
applyWikiTemplate :: Html -> ContentTransformer Response
applyWikiTemplate Html
c = do
  Context { ctxLayout :: Context -> PageLayout
ctxLayout = PageLayout
layout } <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PageLayout -> Html -> Handler
formattedPage PageLayout
layout Html
c

--
-- Content-type transformation combinators
--

-- | Converts Page to Pandoc, applies page transforms, and adds page
-- title.
pageToWikiPandoc :: Page -> ContentTransformer Pandoc
pageToWikiPandoc :: Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc Page
page' =
  Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc' Page
page' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Pandoc -> StateT Context GititServerPart Pandoc
addPageTitleToPandoc (Page -> String
pageTitle Page
page')

pageToWikiPandoc' :: Page -> ContentTransformer Pandoc
pageToWikiPandoc' :: Page -> StateT Context GititServerPart Pandoc
pageToWikiPandoc' = Page -> StateT Context GititServerPart Page
applyPreParseTransforms forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                     Page -> StateT Context GititServerPart Pandoc
pageToPandoc forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Pandoc -> StateT Context GititServerPart Pandoc
applyPageTransforms

-- | Converts source text to Pandoc using default page type.
pageToPandoc :: Page -> ContentTransformer Pandoc
pageToPandoc :: Page -> StateT Context GititServerPart Pandoc
pageToPandoc Page
page' = do
  forall (m :: * -> *). HasContext m => (Context -> Context) -> m ()
modifyContext forall a b. (a -> b) -> a -> b
$ \Context
ctx -> Context
ctx{ ctxTOC :: Bool
ctxTOC = Page -> Bool
pageTOC Page
page'
                             , ctxCategories :: [String]
ctxCategories = Page -> [String]
pageCategories Page
page'
                             , ctxMeta :: [(String, String)]
ctxMeta = Page -> [(String, String)]
pageMeta Page
page' }
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
E.throwIO) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PageType -> Bool -> String -> Either PandocError Pandoc
readerFor (Page -> PageType
pageFormat Page
page') (Page -> Bool
pageLHS Page
page') (Page -> String
pageText Page
page')

-- | Detects if the page is a redirect page and handles accordingly. The exact
-- behaviour is as follows:
--
-- If the page is /not/ a redirect page (the most common case), then check the
-- referer to see if the client came to this page as a result of a redirect
-- from another page. If so, then add a notice to the messages to notify the
-- user that they were redirected from another page, and provide a link back
-- to the original page, with an extra parameter to disable redirection
-- (e.g., to allow the original page to be edited).
--
-- If the page /is/ a redirect page, then check the query string for the
-- @redirect@ parameter. This can modify the behaviour of the redirect as
-- follows:
--
-- 1. If the @redirect@ parameter is unset, then check the referer to see if
--    client came to this page as a result of a redirect from another page. If
--    so, then do not redirect, and add a notice to the messages explaining
--    that this page is a redirect page, that would have redirected to the
--    destination given in the metadata (and provide a link thereto), but this
--    was stopped because a double-redirect was detected. This is a simple way
--    to prevent cyclical redirects and other abuses enabled by redirects.
--    redirect to the same page. If the client did /not/ come to this page as
--    a result of a redirect, then redirect back to the same page, except with
--    the redirect parameter set to @\"yes\"@.
--
-- 2. If the @redirect@ parameter is set to \"yes\", then redirect to the
--    destination specificed in the metadata. This uses a client-side (meta
--    refresh + javascript backup) redirect to make sure the referer is set to
--    this URL.
--
-- 3. If the @redirect@ parameter is set to \"no\", then do not redirect, but
--    add a notice to the messages that this page /would/ have redirected to
--    the destination given in the metadata had it not been disabled, and
--    provide a link to the destination given in the metadata. This behaviour
--    is the @revision@ parameter is present in the query string.
handleRedirects :: Page -> ContentTransformer (Either Response Page)
handleRedirects :: Page -> StateT Context GititServerPart (Either Response Page)
handleRedirects Page
page = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"redirect" (Page -> [(String, String)]
pageMeta Page
page) of
    Maybe String
Nothing -> forall {a}. StateT Context GititServerPart (Either a Page)
isn'tRedirect
    Just String
destination -> String -> StateT Context GititServerPart (Either Response Page)
isRedirect String
destination
  where
    addMessage :: String -> m ()
addMessage String
message = forall (m :: * -> *). HasContext m => (Context -> Context) -> m ()
modifyContext forall a b. (a -> b) -> a -> b
$ \Context
context -> Context
context
        { ctxLayout :: PageLayout
ctxLayout = (Context -> PageLayout
ctxLayout Context
context)
            { pgMessages :: [String]
pgMessages = PageLayout -> [String]
pgMessages (Context -> PageLayout
ctxLayout Context
context) forall a. [a] -> [a] -> [a]
++ [String
message]
            }
        }
    redirectedFrom :: String -> m String
redirectedFrom String
source = do
        (String
url, String
html) <- forall {m :: * -> *}. ServerMonad m => String -> m (String, String)
processSource String
source
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Redirected from <a href=\""
            , String
url
            , String
"?redirect=no\" title=\"Go to original page\">"
            , String
html
            , String
"</a>"
            ]
    doubleRedirect :: String -> String -> m String
doubleRedirect String
source String
destination = do
        (String
url, String
html) <- forall {m :: * -> *}. ServerMonad m => String -> m (String, String)
processSource String
source
        (String
url', String
html') <- forall {m :: * -> *}. ServerMonad m => String -> m (String, String)
processDestination String
destination
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"This page normally redirects to <a href=\""
            , String
url'
            , String
"\" title=\"Continue to destination\">"
            , String
html'
            , String
"</a>, but as you were already redirected from <a href=\""
            , String
url
            , String
"?redirect=no\" title=\"Go to original page\">"
            , String
html
            , String
"</a>"
            , String
", this was stopped to prevent a double-redirect."
            ]
    cancelledRedirect :: String -> m String
cancelledRedirect String
destination = do
        (String
url', String
html') <- forall {m :: * -> *}. ServerMonad m => String -> m (String, String)
processDestination String
destination
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"This page redirects to <a href=\""
            , String
url'
            , String
"\" title=\"Continue to destination\">"
            , String
html'
            , String
"</a>."
            ]
    processSource :: String -> m (String, String)
processSource String
source = do
        String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        let url :: String
url = String -> String
stringToHtmlString forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String -> String
urlForPage String
source
        let html :: String
html = String -> String
stringToHtmlString String
source
        forall (m :: * -> *) a. Monad m => a -> m a
return (String
url, String
html)
    processDestination :: String -> m (String, String)
processDestination String
destination = do
        String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        let (String
page', String
fragment) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'#') String
destination
        let url :: String
url = String -> String
stringToHtmlString forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ String
base'
             , String -> String
urlForPage String
page'
             , String
fragment
             ]
        let html :: String
html = String -> String
stringToHtmlString String
page'
        forall (m :: * -> *) a. Monad m => a -> m a
return (String
url, String
html)
    getSource :: ContentTransformer (Maybe String)
getSource = do
        Config
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
        String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
        Request
request <- forall (m :: * -> *). ServerMonad m => m Request
askRq
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
            ByteString
referer <- forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"referer" Request
request
            URIRef Absolute
uri <- case URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
laxURIParserOptions ByteString
referer of
                Left URIParseError
_ -> forall a. Maybe a
Nothing
                Right URIRef Absolute
uri -> forall a. a -> Maybe a
Just URIRef Absolute
uri
            let Query [(ByteString, ByteString)]
params = URIRef Absolute -> Query
uriQuery URIRef Absolute
uri
            ByteString
redirect' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
SC.pack String
"redirect") [(ByteString, ByteString)]
params
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString
redirect' forall a. Eq a => a -> a -> Bool
== String -> ByteString
SC.pack String
"yes"
            String
path' <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String
base' forall a. [a] -> [a] -> [a]
++ String
"/") (ByteString -> String
SC.unpack (URIRef Absolute -> ByteString
uriPath URIRef Absolute
uri))
            let path'' :: String
path'' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then Config -> String
frontPage Config
cfg else String -> String
urlDecode String
path'
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String -> Bool
isPage String
path''
            forall (m :: * -> *) a. Monad m => a -> m a
return String
path''
    withBody :: String -> Response
withBody = String -> Response -> Response
setContentType String
"text/html; charset=utf-8" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMessage a => a -> Response
toResponse
    isn'tRedirect :: StateT Context GititServerPart (Either a Page)
isn'tRedirect = do
        ContentTransformer (Maybe String)
getSource forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *}. ServerMonad m => String -> m String
redirectedFrom forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {m :: * -> *}. HasContext m => String -> m ()
addMessage)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Page
page)
    isRedirect :: String -> StateT Context GititServerPart (Either Response Page)
isRedirect String
destination = do
        Params
params <- ContentTransformer Params
getParams
        case forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Params -> Maybe Bool
pRedirect Params
params) (\String
_ -> forall a. a -> Maybe a
Just Bool
False) (Params -> Maybe String
pRevision Params
params) of
             Maybe Bool
Nothing -> do
                Maybe String
source <- ContentTransformer (Maybe String)
getSource
                case Maybe String
source of
                     Just String
source' -> do
                        forall {m :: * -> *}. ServerMonad m => String -> String -> m String
doubleRedirect String
source' String
destination forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. HasContext m => String -> m ()
addMessage
                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Page
page)
                     Maybe String
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
                        String
base' <- forall (m :: * -> *). ServerMonad m => m String
getWikiBase
                        let url' :: String
url' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                             [ String
base'
                             , String -> String
urlForPage (Page -> String
pageName Page
page)
                             , String
"?redirect=yes"
                             ]
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther String
url' forall a b. (a -> b) -> a -> b
$ String -> Response
withBody forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [ String
"<!doctype html><html><head><title>307 Redirect"
                            , String
"</title></head><body><p>You are being <a href=\""
                            , String -> String
stringToHtmlString String
url'
                            , String
"\">redirected</a>.</body></p></html>"
                            ]
             Just Bool
True -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
                (String
url', String
html') <- forall {m :: * -> *}. ServerMonad m => String -> m (String, String)
processDestination String
destination
                forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok forall a b. (a -> b) -> a -> b
$ String -> Response
withBody forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"<!doctype html><html><head><title>Redirecting to "
                    , String
html'
                    , String
"</title><meta http-equiv=\"refresh\" contents=\"0; url="
                    , String
url'
                    , String
"\" /><script type=\"text/javascript\">window.location=\""
                    , String
url'
                    , String
"\"</script></head><body><p>Redirecting to <a href=\""
                    , String
url'
                    , String
"\">"
                    , String
html'
                    , String
"</a>...</p></body></html>"
                    ]
             Just Bool
False -> do
                forall {m :: * -> *}. ServerMonad m => String -> m String
cancelledRedirect String
destination forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. HasContext m => String -> m ()
addMessage
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Page
page)

-- | Converts contents of page file to Page object.
contentsToPage :: String -> ContentTransformer Page
contentsToPage :: String -> StateT Context GititServerPart Page
contentsToPage String
s = do
  Config
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  String
pn <- ContentTransformer String
getPageName
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config -> String -> String -> Page
stringToPage Config
cfg String
pn String
s

-- | Converts pandoc document to HTML.
pandocToHtml :: Pandoc -> ContentTransformer Html
pandocToHtml :: Pandoc -> StateT Context GititServerPart Html
pandocToHtml Pandoc
pandocContents = do
  Bool
toc <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxTOC forall s (m :: * -> *). MonadState s m => m s
get
  Bool
bird <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxBirdTracks forall s (m :: * -> *). MonadState s m => m s
get
  Config
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  let tpl :: Text
tpl = Text
"$if(toc)$<div id=\"TOC\">\n$toc$\n</div>\n$endif$\n$body$"
  Template Text
compiledTemplate <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PandocIO a -> IO a
runIOorExplode forall a b. (a -> b) -> a -> b
$ do
    Either String (Template Text)
res <- forall (m :: * -> *) a. WithDefaultPartials m a -> m a
runWithDefaultPartials forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate String
"toc" Text
tpl
    case Either String (Template Text)
res of
      Right Template Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Template Text
t
      Left String
e  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocTemplateError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
e
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Html
primHtml forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (if Config -> Bool
xssSanitize Config
cfg then Text -> Text
sanitizeBalance else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
           forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
E.throw forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PandocPure a -> Either PandocError a
runPure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String forall a. Default a => a
def{
                        writerTemplate :: Maybe (Template Text)
writerTemplate = forall a. a -> Maybe a
Just Template Text
compiledTemplate
                      , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod =
                            case Config -> MathMethod
mathMethod Config
cfg of
                                 MathMethod
MathML -> HTMLMathMethod
Pandoc.MathML
                                 WebTeX String
u -> Text -> HTMLMathMethod
Pandoc.WebTeX forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
u
                                 MathJax String
u -> Text -> HTMLMathMethod
Pandoc.MathJax forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
u
                                 MathMethod
RawTeX -> HTMLMathMethod
Pandoc.PlainMath
                      , writerTableOfContents :: Bool
writerTableOfContents = Bool
toc
                      , writerHighlightStyle :: Maybe Style
writerHighlightStyle = forall a. a -> Maybe a
Just Style
pygments
                      , writerExtensions :: Extensions
writerExtensions = if Bool
bird
                                              then Extension -> Extensions -> Extensions
enableExtension Extension
Ext_literate_haskell
                                                   forall a b. (a -> b) -> a -> b
$ WriterOptions -> Extensions
writerExtensions forall a. Default a => a
def
                                              else WriterOptions -> Extensions
writerExtensions forall a. Default a => a
def
                      -- note: javascript obfuscation gives problems on preview
                      , writerEmailObfuscation :: ObfuscationMethod
writerEmailObfuscation = ObfuscationMethod
ReferenceObfuscation
                      } Pandoc
pandocContents

-- | Returns highlighted source code.
highlightSource :: Maybe String -> ContentTransformer Html
highlightSource :: Maybe String -> StateT Context GititServerPart Html
highlightSource Maybe String
Nothing = forall (m :: * -> *) a. MonadPlus m => m a
mzero
highlightSource (Just String
source) = do
  String
file <- ContentTransformer String
getFileName
  let formatOpts :: FormatOptions
formatOpts = FormatOptions
defaultFormatOpts { numberLines :: Bool
numberLines = Bool
True, lineAnchors :: Bool
lineAnchors = Bool
True }
  case SyntaxMap -> String -> [Syntax]
syntaxesByFilename SyntaxMap
defaultSyntaxMap String
file of
        []    -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
        (Syntax
l:[Syntax]
_) -> case TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
tokenize TokenizerConfig{
                              syntaxMap :: SyntaxMap
syntaxMap = SyntaxMap
defaultSyntaxMap
                            , traceOutput :: Bool
traceOutput = Bool
False} Syntax
l
                        forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\r') String
source of
                    Left String
e ->  forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show String
e)
                    Right [SourceLine]
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Html
primHtml forall a b. (a -> b) -> a -> b
$ Html -> String
Blaze.renderHtml
                                      forall a b. (a -> b) -> a -> b
$ FormatOptions -> [SourceLine] -> Html
formatHtmlBlock FormatOptions
formatOpts [SourceLine]
r

--
-- Plugin combinators
--

getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms :: ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (Pandoc -> PluginM Pandoc)
pageTransform) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where pageTransform :: Plugin -> Maybe (Pandoc -> PluginM Pandoc)
pageTransform (PageTransform Pandoc -> PluginM Pandoc
x) = forall a. a -> Maybe a
Just Pandoc -> PluginM Pandoc
x
        pageTransform Plugin
_                 = forall a. Maybe a
Nothing

getPreParseTransforms :: ContentTransformer [String -> PluginM String]
getPreParseTransforms :: ContentTransformer [String -> PluginM String]
getPreParseTransforms = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (String -> PluginM String)
preParseTransform) forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where preParseTransform :: Plugin -> Maybe (String -> PluginM String)
preParseTransform (PreParseTransform String -> PluginM String
x) = forall a. a -> Maybe a
Just String -> PluginM String
x
        preParseTransform Plugin
_                     = forall a. Maybe a
Nothing

getPreCommitTransforms :: ContentTransformer [String -> PluginM String]
getPreCommitTransforms :: ContentTransformer [String -> PluginM String]
getPreCommitTransforms = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Plugin -> Maybe (String -> PluginM String)
preCommitTransform) forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> [Plugin]
plugins
  where preCommitTransform :: Plugin -> Maybe (String -> PluginM String)
preCommitTransform (PreCommitTransform String -> PluginM String
x) = forall a. a -> Maybe a
Just String -> PluginM String
x
        preCommitTransform Plugin
_                      = forall a. Maybe a
Nothing

-- | @applyTransform a t@ applies the transform @t@ to input @a@.
applyTransform :: a -> (a -> PluginM a) -> ContentTransformer a
applyTransform :: forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform a
inp a -> PluginM a
transform = do
  Context
context <- forall s (m :: * -> *). MonadState s m => m s
get
  Config
conf <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  Maybe User
user <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart (Maybe User)
getLoggedInUser
  FileStore
fs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart FileStore
getFileStore
  Request
req <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). ServerMonad m => m Request
askRq
  let pluginData :: PluginData
pluginData = PluginData{ pluginConfig :: Config
pluginConfig = Config
conf
                             , pluginUser :: Maybe User
pluginUser = Maybe User
user
                             , pluginRequest :: Request
pluginRequest = Request
req
                             , pluginFileStore :: FileStore
pluginFileStore = FileStore
fs }
  (a
result', Context
context') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. PluginM a -> PluginData -> Context -> IO (a, Context)
runPluginM (a -> PluginM a
transform a
inp) PluginData
pluginData Context
context
  forall s (m :: * -> *). MonadState s m => s -> m ()
put Context
context'
  forall (m :: * -> *) a. Monad m => a -> m a
return a
result'

-- | Applies all the page transform plugins to a Pandoc document.
applyPageTransforms :: Pandoc -> ContentTransformer Pandoc
applyPageTransforms :: Pandoc -> StateT Context GititServerPart Pandoc
applyPageTransforms Pandoc
c = do
  [Pandoc -> PluginM Pandoc]
xforms <- ContentTransformer [Pandoc -> PluginM Pandoc]
getPageTransforms
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform Pandoc
c (Pandoc -> PluginM Pandoc
wikiLinksTransform forall a. a -> [a] -> [a]
: [Pandoc -> PluginM Pandoc]
xforms)

-- | Applies all the pre-parse transform plugins to a Page object.
applyPreParseTransforms :: Page -> ContentTransformer Page
applyPreParseTransforms :: Page -> StateT Context GititServerPart Page
applyPreParseTransforms Page
page' = ContentTransformer [String -> PluginM String]
getPreParseTransforms forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform (Page -> String
pageText Page
page') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                (\String
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Page
page'{ pageText :: String
pageText = String
t })

-- | Applies all the pre-commit transform plugins to a raw string.
applyPreCommitTransforms :: String -> ContentTransformer String
applyPreCommitTransforms :: String -> ContentTransformer String
applyPreCommitTransforms String
c = ContentTransformer [String -> PluginM String]
getPreCommitTransforms forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall a. a -> (a -> PluginM a) -> ContentTransformer a
applyTransform String
c

--
-- Content or context augmentation combinators
--

-- | Puts rendered page content into a wikipage div, adding
-- categories.
wikiDivify :: Html -> ContentTransformer Html
wikiDivify :: Html -> StateT Context GititServerPart Html
wikiDivify Html
c = do
  [String]
categories <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> [String]
ctxCategories forall s (m :: * -> *). MonadState s m => m s
get
  String
base' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). ServerMonad m => m String
getWikiBase
  let categoryLink :: String -> Html
categoryLink String
ctg = Html -> Html
li (Html -> Html
anchor forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href forall a b. (a -> b) -> a -> b
$ String
base' forall a. [a] -> [a] -> [a]
++ String
"/_category/" forall a. [a] -> [a] -> [a]
++ String
ctg] forall a b. HTML a => (Html -> b) -> a -> b
<< String
ctg)
  let htmlCategories :: Html
htmlCategories = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
categories
                          then Html
noHtml
                          else Html -> Html
thediv forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"categoryList"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
ulist forall a b. HTML a => (Html -> b) -> a -> b
<< forall a b. (a -> b) -> [a] -> [b]
map String -> Html
categoryLink [String]
categories
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Html -> Html
thediv forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
identifier String
"wikipage"] forall a b. HTML a => (Html -> b) -> a -> b
<< [Html
c, Html
htmlCategories]

-- | Adds page title to a Pandoc document.
addPageTitleToPandoc :: String -> Pandoc -> ContentTransformer Pandoc
addPageTitleToPandoc :: String -> Pandoc -> StateT Context GititServerPart Pandoc
addPageTitleToPandoc String
title' (Pandoc Meta
_ [Block]
blocks) = do
  (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout forall a b. (a -> b) -> a -> b
$ \PageLayout
layout -> PageLayout
layout{ pgTitle :: String
pgTitle = String
title' }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
title'
              then Meta -> [Block] -> Pandoc
Pandoc Meta
nullMeta [Block]
blocks
              else Meta -> [Block] -> Pandoc
Pandoc
                    (forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
B.setMeta Text
"title" (Text -> Inlines
B.str (String -> Text
T.pack String
title')) Meta
nullMeta)
                    [Block]
blocks

-- | Adds javascript links for math support.
addMathSupport :: a -> ContentTransformer a
addMathSupport :: forall a. a -> ContentTransformer a
addMathSupport a
c = do
  Config
conf <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GititServerPart Config
getConfig
  (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout forall a b. (a -> b) -> a -> b
$ \PageLayout
l ->
    case Config -> MathMethod
mathMethod Config
conf of
         MathMethod
MathML       -> PageLayout -> [String] -> PageLayout
addScripts PageLayout
l [String
"MathMLinHTML.js"]
         WebTeX String
_     -> PageLayout
l
         MathJax String
u    -> PageLayout -> [String] -> PageLayout
addScripts PageLayout
l [String
u]
         MathMethod
RawTeX       -> PageLayout
l
  forall (m :: * -> *) a. Monad m => a -> m a
return a
c

-- | Adds javascripts to page layout.
addScripts :: PageLayout -> [String] -> PageLayout
addScripts :: PageLayout -> [String] -> PageLayout
addScripts PageLayout
layout [String]
scriptPaths =
  PageLayout
layout{ pgScripts :: [String]
pgScripts = [String]
scriptPaths forall a. [a] -> [a] -> [a]
++ PageLayout -> [String]
pgScripts PageLayout
layout }

--
-- ContentTransformer context API
--

getParams :: ContentTransformer Params
getParams :: ContentTransformer Params
getParams = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a r.
(HasRqData m, FromData a, MonadPlus m, ServerMonad m) =>
(a -> m r) -> m r
withData forall (m :: * -> *) a. Monad m => a -> m a
return)

getFileName :: ContentTransformer FilePath
getFileName :: ContentTransformer String
getFileName = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> String
ctxFile forall s (m :: * -> *). MonadState s m => m s
get

getPageName :: ContentTransformer String
getPageName :: ContentTransformer String
getPageName = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PageLayout -> String
pgPageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> PageLayout
ctxLayout) forall s (m :: * -> *). MonadState s m => m s
get

getLayout :: ContentTransformer PageLayout
getLayout :: ContentTransformer PageLayout
getLayout = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> PageLayout
ctxLayout forall s (m :: * -> *). MonadState s m => m s
get

getCacheable :: ContentTransformer Bool
getCacheable :: ContentTransformer Bool
getCacheable = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context -> Bool
ctxCacheable forall s (m :: * -> *). MonadState s m => m s
get

-- | Updates the layout with the result of applying f to the current layout
updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout :: (PageLayout -> PageLayout) -> ContentTransformer ()
updateLayout PageLayout -> PageLayout
f = do
  Context
ctx <- forall s (m :: * -> *). MonadState s m => m s
get
  let l :: PageLayout
l = Context -> PageLayout
ctxLayout Context
ctx
  forall s (m :: * -> *). MonadState s m => s -> m ()
put Context
ctx { ctxLayout :: PageLayout
ctxLayout = PageLayout -> PageLayout
f PageLayout
l }

--
-- Pandoc and wiki content conversion support
--

readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc
readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc
readerFor PageType
pt Bool
lhs =
  let defExts :: Extensions
defExts = Text -> Extensions
getDefaultExtensions forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show PageType
pt
      defPS :: ReaderOptions
defPS = forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = Extensions
defExts
                                      forall a. Semigroup a => a -> a -> a
<> [Extension] -> Extensions
extensionsFromList [Extension
Ext_emoji]
                                      forall a. Semigroup a => a -> a -> a
<> PageType -> Bool -> Extensions
getPageTypeDefaultExtensions PageType
pt Bool
lhs
                                      forall a. Semigroup a => a -> a -> a
<> ReaderOptions -> Extensions
readerExtensions forall a. Default a => a
def }
  in forall a. PandocPure a -> Either PandocError a
runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case PageType
pt of
       PageType
RST        -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readRST ReaderOptions
defPS
       PageType
Markdown   -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
defPS
       PageType
CommonMark -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readCommonMark ReaderOptions
defPS
       PageType
LaTeX      -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readLaTeX ReaderOptions
defPS
       PageType
HTML       -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readHtml ReaderOptions
defPS
       PageType
Textile    -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readTextile ReaderOptions
defPS
       PageType
Org        -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOrg ReaderOptions
defPS
       PageType
DocBook    -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readDocBook ReaderOptions
defPS
       PageType
MediaWiki  -> forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMediaWiki ReaderOptions
defPS) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

wikiLinksTransform :: Pandoc -> PluginM Pandoc
wikiLinksTransform :: Pandoc -> PluginM Pandoc
wikiLinksTransform Pandoc
pandoc
  = do Config
cfg <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PluginData -> Config
pluginConfig forall r (m :: * -> *). MonadReader r m => m r
ask -- Can't use askConfig from Interface due to circular dependencies.
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp (Config -> Inline -> Inline
convertWikiLinks Config
cfg) Pandoc
pandoc)

-- | Convert links with no URL to wikilinks.
convertWikiLinks :: Config -> Inline -> Inline
convertWikiLinks :: Config -> Inline -> Inline
convertWikiLinks Config
cfg (Link Attr
attr [Inline]
ref (Text
"", Text
"")) | Config -> Bool
useAbsoluteUrls Config
cfg =
  Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ref (String -> Text
T.pack (String
"/" String -> String -> String
</> Config -> String
baseUrl Config
cfg String -> String -> String
</> [Inline] -> String
inlinesToURL [Inline]
ref),
                 Text
"Go to wiki page")
convertWikiLinks Config
_cfg (Link Attr
attr [Inline]
ref (Text
"", Text
"")) =
  Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ref (String -> Text
T.pack ([Inline] -> String
inlinesToURL [Inline]
ref), Text
"Go to wiki page")
convertWikiLinks Config
_cfg Inline
x = Inline
x

-- | Derives a URL from a list of Pandoc Inline elements.
inlinesToURL :: [Inline] -> String
inlinesToURL :: [Inline] -> String
inlinesToURL = Bool -> (Char -> Bool) -> String -> String
encString Bool
False Char -> Bool
isUnescapedInURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> String
inlinesToString

-- | Convert a list of inlines into a string.
inlinesToString :: [Inline] -> String
inlinesToString :: [Inline] -> String
inlinesToString = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go
  where go :: Inline -> T.Text
        go :: Inline -> Text
go Inline
x = case Inline
x of
               Str Text
s                   -> Text
s
               Emph [Inline]
xs                 -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Strong [Inline]
xs               -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Strikeout [Inline]
xs            -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Superscript [Inline]
xs          -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Subscript [Inline]
xs            -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               SmallCaps [Inline]
xs            -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
#if MIN_VERSION_pandoc(2,10,0)
               Underline [Inline]
xs            -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
#endif
               Quoted QuoteType
DoubleQuote [Inline]
xs   -> Text
"\"" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs) forall a. Semigroup a => a -> a -> a
<> Text
"\""
               Quoted QuoteType
SingleQuote [Inline]
xs   -> Text
"'" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs) forall a. Semigroup a => a -> a -> a
<> Text
"'"
               Cite [Citation]
_ [Inline]
xs               -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Code Attr
_ Text
s                -> Text
s
               Inline
Space                   -> Text
" "
               Inline
SoftBreak               -> Text
" "
               Inline
LineBreak               -> Text
" "
               Math MathType
DisplayMath Text
s      -> Text
"$$" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
"$$"
               Math MathType
InlineMath Text
s       -> Text
"$" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
"$"
               RawInline (Format Text
"tex") Text
s -> Text
s
               RawInline Format
_ Text
_           -> Text
""
               Link Attr
_ [Inline]
xs (Text, Text)
_             -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Image Attr
_ [Inline]
xs (Text, Text)
_            -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs
               Note [Block]
_                  -> Text
""
               Span Attr
_ [Inline]
xs               -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Inline -> Text
go [Inline]
xs